Software Vault: The Gold Collection

home *** CD-ROM | disk | FTP | other *** search

/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr53 / acmalg01.zip / ACM573.FOR < prev next >

Wrap

Text File | 1993-01-01 | 476KB | 13,868 lines

C ALGORITHM 573, COLLECTED ALGORITHMS FROM ACM. THIS WORK C PUBLISHED IN TRANS. MATH. SOFTWARE, 7(3), PP. 369-383. C ALGORITHM 573 C C NL2SOL -- AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM C C AUTHORS = JOHN E. DENNIS, JR., DAVID M. GAY, AND ROY E. WELSCH C C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE, SEPTEMBER, 1981. C C THIS FILE COMES IN 9 SECTIONS, SEPARATED BY A COMMENT LINE HAVING C C IN COLUMN 1 AND SLASHES IN COLUMNS 2-72. THE FIRST SECTION CON- C SISTS OF THESE COMMENTS. SECTIONS 2-5 CONTAIN SINGLE-PRECISION 1966 C ANSI STANDARD FORTRAN SOURCE CODE, AND SECTIONS 6-9 ARE DOUBLE- C PRECISION VERSIONS OF SECTIONS 2-5. COMMENTS IN SECTIONS 4 AND 8 C DESCRIBE AN EASY WAY TO MODIFY THIS CODE FOR USE WITH FORTRAN 77. C THE 9 SECTIONS ARE AS FOLLOWS... C C 1. THESE COMMENTS. C 2. SINGLE-PREC. SHORT TEST PROGRAM. C 3. SINGLE-PREC. MACHINE-DEPENDENT FUNCTIONS IMDCON AND RMDCON. C 4. SINGLE-PREC. MACHINE-INDEPENDENT NL2SOL MODULES. C 5. SINGLE-PREC. LONG TEST PROGRAM. C 6. DOUBLE-PREC. SHORT TEST PROGRAM. C 7. DOUBLE-PREC. MACHINE-DEPENDENT FUNCTIONS IMDCON AND RMDCON. C 8. DOUBLE-PREC. MACHINE-INDEPENDENT NL2SOL MODULES. C 9. DOUBLE-PREC. LONG TEST PROGRAM. C C THE SHORT TEST PROGRAM (SECTIONS 2 AND 6) AMOUNTS TO THE EXAMPLE IN C SECTION 3.2 OF THE DESCRIPTION OF TOMS ALGORITHM 573 WITH AN ADDED C CALL ON NL2SNO. C C DEPENDING ON THE COMPUTER USED, IT MAY BE NECESSARY TO CHANGE THE C DATA STATEMENTS IN SECTIONS 3 AND 7 -- SEE SECTION 3.12 OF THE C DESCRIPTION OF TOMS ALGORITHM 573. (THE VERSION OF RMDCON IN C SECTION 3 IS SET FOR CDC COMPUTERS, AND THAT IN SECTION 8 IS SET FOR C IBM 360 AND 370 COMPUTERS.) C C THE FIRST THREE MODULES IN SECTIONS 4 AND 8 ARE NL2SOL, NL2SNO, AND C NL2ITR. THE REMAINING MODULES FOLLOW IN ALPHABETICAL ORDER. C C THE LONG TEST PROGRAM (SECTIONS 5 AND 9) RUNS THE TESTS REPORTED IN C TABLE II OF THE TOMS PAPER ON NL2SOL. THIS PROGRAM PRODUCES A C ONE-PAGE SUMMARY ON UNIT IMDCON(2) AND DETAILED OUTPUT ON UNIT C IMDCON(1). THE LATTER MAY BE SUPPRESSED BY ARRANGING FOR IMDCON(1) C TO RETURN 0. C C/////////////////////////////////////////////////////////////////////// END C *** TEST NL2SOL AND NL2SNO ON MADSEN EXAMPLE *** MAD00010 INTEGER IV(62), UIPARM(1) REAL V(147), X(2), URPARM(1) EXTERNAL MADR, MADJ X(1) = 3.0 X(2) = 1.0 IV(1) = 0 CALL NL2SOL(3, 2, X, MADR, MADJ, IV, V, UIPARM, URPARM, MADR) IV(1) = 12 X(1) = 3.0 X(2) = 1.0 CALL NL2SNO(3, 2, X, MADR, IV, V, UIPARM, URPARM, MADR) STOP END SUBROUTINE MADR(N, P, X, NF, R, UIPARM, URPARM, UFPARM) INTEGER N, P, NF, UIPARM(1) REAL X(P), R(N), URPARM(1) EXTERNAL UFPARM R(1) = X(1)**2 + X(2)**2 + X(1)*X(2) R(2) = SIN(X(1)) R(3) = COS(X(2)) RETURN END SUBROUTINE MADJ(N, P, X, NF, J, UIPARM, URPARM, UFPARM) INTEGER N, P, NF, UIPARM(1) REAL X(P), J(N,P), URPARM(1) EXTERNAL UFPARM J(1,1) = 2.0*X(1) + X(2) J(1,2) = 2.0*X(2) + X(1) J(2,1) = COS(X(1)) J(2,2) = 0.0 J(3,1) = 0.0 J(3,2) = -SIN(X(2)) RETURN END INTEGER FUNCTION IMDCON(K) IMD00010 C INTEGER K C C *** RETURN INTEGER MACHINE-DEPENDENT CONSTANTS *** C C *** K = 1 MEANS RETURN STANDARD OUTPUT UNIT NUMBER. *** C *** K = 2 MEANS RETURN ALTERNATE OUTPUT UNIT NUMBER. *** C *** K = 3 MEANS RETURN INPUT UNIT NUMBER. *** C (NOTE -- K = 2, 3 ARE USED ONLY BY TEST PROGRAMS.) C INTEGER MDCON(3) DATA MDCON(1)/6/, MDCON(2)/8/, MDCON(3)/5/ C IMDCON = MDCON(K) RETURN C *** LAST CARD OF IMDCON FOLLOWS *** END REAL FUNCTION RMDCON(K) RMD00010 C C *** RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL *** C C +++ COMMENTS BELOW CONTAIN DATA STATEMENTS FOR VARIOUS MACHINES. +++ C +++ TO CONVERT TO ANOTHER MACHINE, PLACE A C IN COLUMN 1 OF THE +++ C +++ DATA STATEMENT LINE(S) THAT CORRESPOND TO THE CURRENT MACHINE +++ C +++ AND REMOVE THE C FROM COLUMN 1 OF THE DATA STATEMENT LINE(S) +++ C +++ THAT CORRESPOND TO THE NEW MACHINE. +++ C INTEGER K C C *** THE CONSTANT RETURNED DEPENDS ON K... C C *** K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS. C *** K = 2... SQUARE ROOT OF 1.001*ETA. C *** K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH C *** THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1. C *** K = 4... SQUARE ROOT OF 0.999*MACHEP. C *** K = 5... SQUARE ROOT OF 0.999*BIG (SEE K = 6). C *** K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS. C REAL BIG, ETA, MACHEP C/+ REAL SQRT C/ REAL ONE001, PT999 C DATA ONE001/1.001/, PT999/0.999/ C C +++ IBM 360, IBM 370, OR XEROX +++ C C DATA BIG/Z7FFFFFFF/, ETA/Z00100000/, MACHEP/Z3C100000/ C C +++ DATA GENERAL +++ C C DATA BIG/0.7237E+76/, ETA/0.5398E-78/, MACHEP/0.9537E-06/ C C +++ DEC 11 +++ C C DATA BIG/1.7E+38/, ETA/2.9388E-39/, MACHEP/1.1921E-07/ C C +++ HP3000 +++ C C DATA BIG/1.1579E+77/, ETA/8.6362E-78/, MACHEP/2.3842E-07/ C C +++ HONEYWELL +++ C C DATA BIG/O376777000000/, ETA/O404400400000/, C 1 MACHEP/O716400000000/ C C +++ DEC10 +++ C C DATA BIG/"377777777777/, ETA/"000400000021/, C 1 MACHEP/"147400000000/ C C +++ BURROUGHS +++ C C DATA BIG/O0777777777777777/, ETA/O1771000000000000/, C 1 MACHEP/O1301000000000000/ C C +++ CONTROL DATA +++ C DATA BIG/37754000000000000000B/, ETA/00024000000000000000B/, 1 MACHEP/16414000000000000000B/ C C +++ PRIME +++ C C DATA BIG/1.7E+38/, ETA/1.47E-39/, MACHEP/2.38419E-7/ C C +++ UNIVAC +++ C C DATA BIG/1.69E+38/, ETA/5.9E-39/, MACHEP/1.4901162E-8/ C C +++ VAX +++ C C DATA BIG/1.7E+38/, ETA/2.939E-39/, MACHEP/5.9604645E-08/ C C------------------------------- BODY -------------------------------- C GO TO (10, 20, 30, 40, 50, 60), K C 10 RMDCON = ETA GO TO 999 C 20 RMDCON = SQRT(ONE001*ETA) GO TO 999 C 30 RMDCON = MACHEP GO TO 999 C 40 RMDCON = SQRT(PT999*MACHEP) GO TO 999 C 50 RMDCON = SQRT(PT999*BIG) GO TO 999 C 60 RMDCON = BIG C 999 RETURN C *** LAST CARD OF RMDCON FOLLOWS *** END SUBROUTINE NL2SOL(N, P, X, CALCR, CALCJ, IV, V, UIPARM, URPARM, NL200010 1 UFPARM) C C *** MINIMIZE NONLINEAR SUM OF SQUARES USING ANALYTIC JACOBIAN *** C *** (NL2SOL VERSION 2.2) *** C INTEGER N, P, IV(1), UIPARM(1) REAL X(P), V(1), URPARM(1) C DIMENSION IV(60+P), V(93 + N*P + 3*N + P*(3*P+33)/2) C DIMENSION UIPARM(*), URPARM(*) EXTERNAL CALCR, CALCJ, UFPARM C C *** PURPOSE *** C C GIVEN A P-VECTOR X OF PARAMETERS, CALCR COMPUTES AN N-VECTOR C R = R(X) OF RESIDUALS CORRESPONDING TO X. (R(X) PROBABLY ARISES C FROM A NONLINEAR MODEL INVOLVING P PARAMETERS AND N OBSERVATIONS.) C THIS ROUTINE INTERACTS WITH NL2ITR TO SEEK A PARAMETER VECTOR X C THAT MINIMIZES THE SUM OF THE SQUARES OF (THE COMPONENTS OF) R(X), C I.E., THAT MINIMIZES THE SUM-OF-SQUARES FUNCTION C F(X) = (R(X)**T) * R(X) / 2. R(X) IS ASSUMED TO BE A TWICE CON- C TINUOUSLY DIFFERENTIABLE FUNCTION OF X. C C-------------------------- PARAMETER USAGE -------------------------- C C N........ (INPUT) THE NUMBER OF OBSERVATIONS, I.E., THE NUMBER OF C COMPONENTS IN R(X). N MUST BE .GE. P. C P........ (INPUT) THE NUMBER OF PARAMETERS (COMPONENTS IN X). P MUST C BE POSITIVE. C X........ (INPUT/OUTPUT). ON INPUT, X IS AN INITIAL GUESS AT THE C DESIRED PARAMETER ESTIMATE. ON OUTPUT, X CONTAINS C THE BEST PARAMETER ESTIMATE FOUND. C CALCR.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES R(X). CALCR C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. C IT IS INVOKED BY C CALL CALCR(N,P,X,NF,R,UIPARM,URPARM,UFPARM) C WHEN CALCR IS CALLED, NF IS THE INVOCATION COUNT C FOR CALCR. IT IS INCLUDED FOR POSSIBLE USE WITH C CALCJ. IF X IS OUT OF BOUNDS (E.G. IF IT WOULD C CAUSE OVERFLOW IN COMPUTING R(X)), THEN CALCR SHOULD C SET NF TO 0. THIS WILL CAUSE A SHORTER STEP TO BE C ATTEMPTED. THE OTHER PARAMETERS ARE AS DESCRIBED C ABOVE AND BELOW. CALCR SHOULD NOT CHANGE N, P, OR X. C CALCJ.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES THE JACOBIAN C MATRIX J OF R AT X, I.E., THE N BY P MATRIX WHOSE C (I,K) ENTRY IS THE PARTIAL DERIVATIVE OF THE I-TH C COMPONENT OF R WITH RESPECT TO X(K). CALCJ MUST BE C DECLARED EXTERNAL IN THE CALLING PROGRAM. IT IS C INVOKED BY C CALL CALCJ(N,P,X,NF,J,UIPARM,URPARM,UFPARM) C NF IS THE INVOCATION COUNT FOR CALCR AT THE TIME C R(X) WAS EVALUATED. THE X PASSED TO CALCJ IS C USUALLY THE ONE PASSED TO CALCR ON EITHER ITS MOST C RECENT INVOCATION OR THE ONE PRIOR TO IT. IF CALCR C SAVES INTERMEDIATE RESULTS FOR USE BY CALCJ, THEN IT C IS POSSIBLE TO TELL FROM NF WHETHER THEY ARE VALID C FOR THE CURRENT X (OR WHICH COPY IS VALID IF TWO C COPIES ARE KEPT). IF J CANNOT BE COMPUTED AT X, C THEN CALCJ SHOULD SET NF TO 0. IN THIS CASE, NL2SOL C WILL RETURN WITH IV(1) = 15. THE OTHER PARAMETERS C TO CALCJ ARE AS DESCRIBED ABOVE AND BELOW. CALCJ C SHOULD NOT CHANGE N, P, OR X. C IV....... (INPUT/OUTPUT) AN INTEGER VALUE ARRAY OF LENGTH AT LEAST C 60 + P THAT HELPS CONTROL THE NL2SOL ALGORITHM AND C THAT IS USED TO STORE VARIOUS INTERMEDIATE QUANTI- C TIES. OF PARTICULAR INTEREST ARE THE INITIALIZATION/ C RETURN CODE IV(1) AND THE ENTRIES IN IV THAT CONTROL C PRINTING AND LIMIT THE NUMBER OF ITERATIONS AND FUNC- C TION EVALUATIONS. SEE THE SECTION ON IV INPUT C VALUES BELOW. C V........ (INPUT/OUTPUT) A FLOATING-POINT VALUE ARRAY OF LENGTH AT C LEAST 93 + N*P + 3*N + P*(3*P+33)/2 THAT HELPS CON- C TROL THE NL2SOL ALGORITHM AND THAT IS USED TO STORE C VARIOUS INTERMEDIATE QUANTITIES. OF PARTICULAR IN- C TEREST ARE THE ENTRIES IN V THAT LIMIT THE LENGTH OF C THE FIRST STEP ATTEMPTED (LMAX0), SPECIFY CONVER- C GENCE TOLERANCES (AFCTOL, RFCTOL, XCTOL, XFTOL), C AND HELP CHOOSE THE STEP SIZE USED IN COMPUTING THE C COVARIANCE MATRIX (DELTA0). SEE THE SECTION ON C (SELECTED) V INPUT VALUES BELOW. C UIPARM... (INPUT) USER INTEGER PARAMETER ARRAY PASSED WITHOUT CHANGE C TO CALCR AND CALCJ. C URPARM... (INPUT) USER FLOATING-POINT PARAMETER ARRAY PASSED WITHOUT C CHANGE TO CALCR AND CALCJ. C UFPARM... (INPUT) USER EXTERNAL SUBROUTINE OR FUNCTION PASSED WITHOUT C CHANGE TO CALCR AND CALCJ. C C *** IV INPUT VALUES (FROM SUBROUTINE DFAULT) *** C C IV(1)... ON INPUT, IV(1) SHOULD HAVE A VALUE BETWEEN 0 AND 12...... C 0 AND 12 MEAN THIS IS A FRESH START. 0 MEANS THAT C DFAULT(IV, V) IS TO BE CALLED TO PROVIDE ALL DEFAULT C VALUES TO IV AND V. 12 (THE VALUE THAT DFAULT ASSIGNS TO C IV(1)) MEANS THE CALLER HAS ALREADY CALLED DFAULT(IV, V) C AND HAS POSSIBLY CHANGED SOME IV AND/OR V ENTRIES TO NON- C DEFAULT VALUES. DEFAULT = 12. C IV(COVPRT)... IV(14) = 1 MEANS PRINT A COVARIANCE MATRIX AT THE SOLU- C TION. (THIS MATRIX IS COMPUTED JUST BEFORE A RETURN WITH C IV(1) = 3, 4, 5, 6.) C IV(COVPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(COVREQ)... IV(15) = NONZERO MEANS COMPUTE A COVARIANCE MATRIX C JUST BEFORE A RETURN WITH IV(1) = 3, 4, 5, 6. IN C THIS CASE, AN APPROXIMATE COVARIANCE MATRIX IS OBTAINED C IN ONE OF SEVERAL WAYS. LET K = ABS(IV(COVREQ)) AND LET C SCALE = 2*F(X)/MAX(1,N-P), WHERE 2*F(X) IS THE RESIDUAL C SUM OF SQUARES. IF K = 1 OR 2, THEN A FINITE-DIFFERENCE C HESSIAN APPROXIMATION H IS OBTAINED. IF H IS POSITIVE C DEFINITE (OR, FOR K = 3, IF THE JACOBIAN MATRIX J AT X C IS NONSINGULAR), THEN ONE OF THE FOLLOWING IS COMPUTED... C K = 1.... SCALE * H**-1 * (J**T * J) * H**-1. C K = 2.... SCALE * H**-1. C K = 3.... SCALE * (J**T * J)**-1. C (J**T IS THE TRANSPOSE OF J, WHILE **-1 MEANS INVERSE.) C IF IV(COVREQ) IS POSITIVE, THEN BOTH FUNCTION AND GRAD- C IENT VALUES (CALLS ON CALCR AND CALCJ) ARE USED IN COM- C PUTING H (WITH STEP SIZES DETERMINED USING V(DELTA0) -- C SEE BELOW), WHILE IF IV(COVREQ) IS NEGATIVE, THEN ONLY C FUNCTION VALUES (CALLS ON CALCR) ARE USED (WITH STEP C SIZES DETERMINED USING V(DLTFDC) -- SEE BELOW). IF C IV(COVREQ) = 0, THEN NO ATTEMPT IS MADE TO COMPUTE A CO- C VARIANCE MATRIX (UNLESS IV(COVPRT) = 1, IN WHICH CASE C IV(COVREQ) = 1 IS ASSUMED). SEE IV(COVMAT) BELOW. C DEFAULT = 1. C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D (SEE REF. 1) SHOULD C BE CHOSEN. IV(DTYPE) .GE. 1 MEANS CHOOSE D AS DESCRIBED C BELOW WITH V(DFAC). IV(DTYPE) .LE. 0 MEANS THE CALLER C HAS CHOSEN D AND HAS STORED IT IN V STARTING AT C V(94 + 2*N + P*(3*P + 31)/2). DEFAULT = 1. C IV(INITS).... IV(25) TELLS HOW THE S MATRIX (SEE REF. 1) SHOULD BE C INITIALIZED. 0 MEANS INITIALIZE S TO 0 (AND START WITH C THE GAUSS-NEWTON MODEL). 1 AND 2 MEAN THAT THE CALLER C HAS STORED THE LOWER TRIANGLE OF THE INITIAL S ROWWISE IN C V STARTING AT V(87+2*P). IV(INITS) = 1 MEANS START WITH C THE GAUSS-NEWTON MODEL, WHILE IV(INITS) = 2 MEANS START C WITH THE AUGMENTED MODEL (SEE REF. 1). DEFAULT = 0. C IV(MXFCAL)... IV(17) GIVES THE MAXIMUM NUMBER OF FUNCTION EVALUATIONS C (CALLS ON CALCR, EXCLUDING THOSE USED TO COMPUTE THE CO- C VARIANCE MATRIX) ALLOWED. IF THIS NUMBER DOES NOT SUF- C FICE, THEN NL2SOL RETURNS WITH IV(1) = 9. DEFAULT = 200. C IV(MXITER)... IV(18) GIVES THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C IT ALSO INDIRECTLY LIMITS THE NUMBER OF GRADIENT EVALUA- C TIONS (CALLS ON CALCJ, EXCLUDING THOSE USED TO COMPUTE C THE COVARIANCE MATRIX) TO IV(MXITER) + 1. IF IV(MXITER) C ITERATIONS DO NOT SUFFICE, THEN NL2SOL RETURNS WITH C IV(1) = 10. DEFAULT = 150. C IV(OUTLEV)... IV(19) CONTROLS THE NUMBER AND LENGTH OF ITERATION SUM- C MARY LINES PRINTED (BY ITSMRY). IV(OUTLEV) = 0 MEANS DO C NOT PRINT ANY SUMMARY LINES. OTHERWISE, PRINT A SUMMARY C LINE AFTER EACH ABS(IV(OUTLEV)) ITERATIONS. IF IV(OUTLEV) C IS POSITIVE, THEN SUMMARY LINES OF LENGTH 117 (PLUS CARRI- C AGE CONTROL) ARE PRINTED, INCLUDING THE FOLLOWING... THE C ITERATION AND FUNCTION EVALUATION COUNTS, CURRENT FUNC- C TION VALUE (V(F) = HALF THE SUM OF SQUARES), RELATIVE C DIFFERENCE IN FUNCTION VALUES ACHIEVED BY THE LATEST STEP C (I.E., RELDF = (F0-V(F))/F0, WHERE F0 IS THE FUNCTION C VALUE FROM THE PREVIOUS ITERATION), THE RELATIVE FUNCTION C REDUCTION PREDICTED FOR THE STEP JUST TAKEN (I.E., C PRELDF = V(PREDUC) / F0, WHERE V(PREDUC) IS DESCRIBED C BELOW), THE SCALED RELATIVE CHANGE IN X (SEE V(RELDX) C BELOW), THE MODELS USED IN THE CURRENT ITERATION (G = C GAUSS-NEWTON, S=AUGMENTED), THE MARQUARDT PARAMETER C STPPAR USED IN COMPUTING THE LAST STEP, THE SIZING FACTOR C USED IN UPDATING S, THE 2-NORM OF THE SCALE VECTOR D C TIMES THE STEP JUST TAKEN (SEE REF. 1), AND NPRELDF, I.E., C V(NREDUC)/F0, WHERE V(NREDUC) IS DESCRIBED BELOW -- IF C NPRELDF IS POSITIVE, THEN IT IS THE RELATIVE FUNCTION C REDUCTION PREDICTED FOR A NEWTON STEP (ONE WITH C STPPAR = 0). IF NPRELDF IS ZERO, EITHER THE GRADIENT C VANISHES (AS DOES PRELDF) OR ELSE THE AUGMENTED MODEL C IS BEING USED AND ITS HESSIAN IS INDEFINITE (WITH PRELDF C POSITIVE). IF NPRELDF IS NEGATIVE, THEN IT IS THE NEGA- C OF THE RELATIVE FUNCTION REDUCTION PREDICTED FOR A STEP C COMPUTED WITH STEP BOUND V(LMAX0) FOR USE IN TESTING FOR C SINGULAR CONVERGENCE. C IF IV(OUTLEV) IS NEGATIVE, THEN LINES OF MAXIMUM C LENGTH 79 (OR 55 IS IV(COVPRT) = 0) ARE PRINTED, INCLUD- C ING ONLY THE FIRST 6 ITEMS LISTED ABOVE (THROUGH RELDX). C DEFAULT = 1. C IV(PARPRT)... IV(20) = 1 MEANS PRINT ANY NONDEFAULT V VALUES ON A C FRESH START OR ANY CHANGED V VALUES ON A RESTART. C IV(PARPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(PRUNIT)... IV(21) IS THE OUTPUT UNIT NUMBER ON WHICH ALL PRINTING C IS DONE. IV(PRUNIT) = 0 MEANS SUPPRESS ALL PRINTING. C (SETTING IV(PRUNIT) TO 0 IS THE ONLY WAY TO SUPPRESS THE C ONE-LINE TERMINATION REASON MESSAGE PRINTED BY ITSMRY.) C DEFAULT = STANDARD OUTPUT UNIT (UNIT 6 ON MOST SYSTEMS). C IV(SOLPRT)... IV(22) = 1 MEANS PRINT OUT THE VALUE OF X RETURNED (AS C WELL AS THE CORRESPONDING GRADIENT AND SCALE VECTOR D). C IV(SOLPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(STATPR)... IV(23) = 1 MEANS PRINT SUMMARY STATISTICS UPON RETURN- C ING. THESE CONSIST OF THE FUNCTION VALUE (HALF THE SUM C OF SQUARES) AT X, V(RELDX) (SEE BELOW), THE NUMBER OF C FUNCTION AND GRADIENT EVALUATIONS (CALLS ON CALCR AND C CALCJ RESPECTIVELY, EXCLUDING ANY CALLS USED TO COMPUTE C THE COVARIANCE), THE RELATIVE FUNCTION REDUCTIONS PREDICT- C ED FOR THE LAST STEP TAKEN AND FOR A NEWTON STEP (OR PER- C HAPS A STEP BOUNDED BY V(LMAX0) -- SEE THE DESCRIPTIONS C OF PRELDF AND NPRELDF UNDER IV(OUTLEV) ABOVE), AND (IF AN C ATTEMPT WAS MADE TO COMPUTE THE COVARIANCE) THE NUMBER OF C CALLS ON CALCR AND CALCJ USED IN TRYING TO COMPUTE THE C COVARIANCE. IV(STATPR) = 0 MEANS SKIP THIS PRINTING. C DEFAULT = 1. C IV(X0PRT).... IV(24) = 1 MEANS PRINT THE INITIAL X AND SCALE VECTOR D C (ON A FRESH START ONLY). IV(X0PRT) = 0 MEANS SKIP THIS C PRINTING. DEFAULT = 1. C C *** (SELECTED) IV OUTPUT VALUES *** C C IV(1)........ ON OUTPUT, IV(1) IS A RETURN CODE.... C 3 = X-CONVERGENCE. THE SCALED RELATIVE DIFFERENCE BE- C TWEEN THE CURRENT PARAMETER VECTOR X AND A LOCALLY C OPTIMAL PARAMETER VECTOR IS VERY LIKELY AT MOST C V(XCTOL). C 4 = RELATIVE FUNCTION CONVERGENCE. THE RELATIVE DIFFER- C ENCE BETWEEN THE CURRENT FUNCTION VALUE AND ITS LO- C CALLY OPTIMAL VALUE IS VERY LIKELY AT MOST V(RFCTOL). C 5 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE (I.E., THE C CONDITIONS FOR IV(1) = 3 AND IV(1) = 4 BOTH HOLD). C 6 = ABSOLUTE FUNCTION CONVERGENCE. THE CURRENT FUNCTION C VALUE IS AT MOST V(AFCTOL) IN ABSOLUTE VALUE. C 7 = SINGULAR CONVERGENCE. THE HESSIAN NEAR THE CURRENT C ITERATE APPEARS TO BE SINGULAR OR NEARLY SO, AND A C STEP OF LENGTH AT MOST V(LMAX0) IS UNLIKELY TO YIELD C A RELATIVE FUNCTION DECREASE OF MORE THAN V(RFCTOL). C 8 = FALSE CONVERGENCE. THE ITERATES APPEAR TO BE CONVERG- C ING TO A NONCRITICAL POINT. THIS MAY MEAN THAT THE C CONVERGENCE TOLERANCES (V(AFCTOL), V(RFCTOL), C V(XCTOL)) ARE TOO SMALL FOR THE ACCURACY TO WHICH C THE FUNCTION AND GRADIENT ARE BEING COMPUTED, THAT C THERE IS AN ERROR IN COMPUTING THE GRADIENT, OR THAT C THE FUNCTION OR GRADIENT IS DISCONTINUOUS NEAR X. C 9 = FUNCTION EVALUATION LIMIT REACHED WITHOUT OTHER CON- C VERGENCE (SEE IV(MXFCAL)). C 10 = ITERATION LIMIT REACHED WITHOUT OTHER CONVERGENCE C (SEE IV(MXITER)). C 11 = STOPX RETURNED .TRUE. (EXTERNAL INTERRUPT). SEE THE C USAGE NOTES BELOW. C 13 = F(X) CANNOT BE COMPUTED AT THE INITIAL X. C 14 = BAD PARAMETERS PASSED TO ASSESS (WHICH SHOULD NOT C OCCUR). C 15 = THE JACOBIAN COULD NOT BE COMPUTED AT X (SEE CALCJ C ABOVE). C 16 = N OR P (OR PARAMETER NN TO NL2ITR) OUT OF RANGE -- C P .LE. 0 OR N .LT. P OR NN .LT. N. C 17 = RESTART ATTEMPTED WITH N OR P (OR PAR. NN TO NL2ITR) C CHANGED. C 18 = IV(INITS) IS OUT OF RANGE. C 19...45 = V(IV(1)) IS OUT OF RANGE. C 50 = IV(1) WAS OUT OF RANGE. C 87...(86+P) = JTOL(IV(1)-86) (I.E., V(IV(1)) IS NOT C POSITIVE (SEE V(DFAC) BELOW). C IV(COVMAT)... IV(26) TELLS WHETHER A COVARIANCE MATRIX WAS COMPUTED. C IF (IV(COVMAT) IS POSITIVE, THEN THE LOWER TRIANGLE OF C THE COVARIANCE MATRIX IS STORED ROWWISE IN V STARTING AT C V(IV(COVMAT)). IF IV(COVMAT) = 0, THEN NO ATTEMPT WAS C MADE TO COMPUTE THE COVARIANCE. IF IV(COVMAT) = -1, C THEN THE FINITE-DIFFERENCE HESSIAN WAS INDEFINITE. AND C AND IF IV(COVMAT) = -2, THEN A SUCCESSFUL FINITE-DIFFER- C ENCING STEP COULD NOT BE FOUND FOR SOME COMPONENT OF X C (I.E., CALCR SET NF TO 0 FOR EACH OF TWO TRIAL STEPS). C NOTE THAT IV(COVMAT) IS RESET TO 0 AFTER EACH SUCCESSFUL C STEP, SO IF SUCH A STEP IS TAKEN AFTER A RESTART, THEN C THE COVARIANCE MATRIX WILL BE RECOMPUTED. C IV(D)........ IV(27) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT C SCALE VECTOR D. C IV(G)........ IV(28) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT C LEAST-SQUARES GRADIENT VECTOR (J**T)*R. C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCR (I.E., C FUNCTION EVALUATIONS, INCLUDING THOSE USED IN COMPUTING C THE COVARIANCE). C IV(NFCOV).... IV(40) IS THE NUMBER OF CALLS MADE ON CALCR WHEN C TRYING TO COMPUTE COVARIANCE MATRICES. C IV(NGCALL)... IV(30) IS THE NUMBER OF GRADIENT EVALUATIONS (CALLS ON C CALCJ) SO FAR DONE (INCLUDING THOSE USED FOR COMPUTING C THE COVARIANCE). C IV(NGCOV).... IV(41) IS THE NUMBER OF CALLS MADE ON CALCJ WHEN C TRYING TO COMPUTE COVARIANCE MATRICES. C IV(NITER).... IV(31) IS THE NUMBER OF ITERATIONS PERFORMED. C IV(R)........ IV(50) IS THE STARTING SUBSCRIPT IN V OF THE RESIDUAL C VECTOR R CORRESPONDING TO X. C C *** (SELECTED) V INPUT VALUES (FROM SUBROUTINE DFAULT) *** C C V(AFCTOL)... V(31) IS THE ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. C IF NL2SOL FINDS A POINT WHERE THE FUNCTION VALUE (HALF C THE SUM OF SQUARES) IS LESS THAN V(AFCTOL), AND IF NL2SOL C DOES NOT RETURN WITH IV(1) = 3, 4, OR 5, THEN IT RETURNS C WITH IV(1) = 6. DEFAULT = MAX(10**-20, MACHEP**2), WHERE C MACHEP IS THE UNIT ROUNDOFF. C V(DELTA0)... V(44) IS A FACTOR USED IN CHOOSING THE FINITE-DIFFERENCE C STEP SIZE USED IN COMPUTING THE COVARIANCE MATRIX WHEN C IV(COVREQ) = 1 OR 2. FOR COMPONENT I, STEP SIZE C V(DELTA0) * MAX(ABS(X(I)), 1/D(I)) * SIGN(X(I)) C IS USED, WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). C (IF THIS STEP RESULTS IN CALCR SETTING NF TO 0, THEN -0.5 C TIMES THIS STEP IS ALSO TRIED.) DEFAULT = MACHEP**0.5, C WHERE MACHEP IS THE UNIT ROUNDOFF. C V(DFAC)..... V(41) AND THE D0 AND JTOL ARRAYS (SEE V(D0INIT) AND C V(JTINIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN C IV(DTYPE) .GT. 0. (D IS INITIALIZED ACCORDING TO C V(DINIT).) LET D1(I) = C MAX(SQRT(JCNORM(I)**2 + MAX(S(I,I),0)), V(DFAC)*D(I)), C WHERE JCNORM(I) IS THE 2-NORM OF THE I-TH COLUMN OF THE C CURRENT JACOBIAN MATRIX AND S IS THE S MATRIX OF REF. 1. C IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I) UNLESS C D1(I) .LT. JTOL(I), IN WHICH CASE D(I) IS SET TO C MAX(D0(I), JTOL(I)). C IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST C ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION C DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER. C DEFAULT = 0.6. C V(DINIT).... V(38), IF NONNEGATIVE, IS THE VALUE TO WHICH THE SCALE C VECTOR D IS INITIALIZED. DEFAULT = 0. C V(DLTFDC)... V(40) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE C COVARIANCE MATRIX WHEN IV(COVREQ) = -1 OR -2. FOR C DIFFERENCES INVOLVING X(I), THE STEP SIZE FIRST TRIED IS C V(DLTFDC) * MAX(ABS(X(I)), 1/D(I)), C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF C THIS STEP IS TOO BIG THE FIRST TIME IT IS TRIED, I.E., IF C CALCR SETS NF TO 0, THEN -0.5 TIMES THIS STEP IS ALSO C TRIED.) DEFAULT = MACHEP**(1/3), WHERE MACHEP IS THE C UNIT ROUNDOFF. C V(D0INIT)... V(37), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED. IF C V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED D0 IN V STARTING AT V(P+87). DEFAULT = 1.0. C V(JTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE JTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED. IF C V(JTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED JTOL IN V STARTING AT V(87). DEFAULT = 10**-6. C V(LMAX0).... V(35) GIVES THE MAXIMUM 2-NORM ALLOWED FOR D TIMES THE C VERY FIRST STEP THAT NL2SOL ATTEMPTS. IT IS ALSO USED C IN TESTING FOR SINGULAR CONVERGENCE -- IF THE FUNCTION C REDUCTION PREDICTED FOR A STEP OF LENGTH BOUNDED BY C V(LMAX0) IS AT MOST V(RFCTOL) * ABS(F0), WHERE F0 IS C THE FUNCTION VALUE AT THE START OF THE CURRENT ITERATION, C AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, OR 6, C THEN IT RETURNS WITH IV(1) = 7. DEFAULT = 100. C V(RFCTOL)... V(32) IS THE RELATIVE FUNCTION CONVERGENCE TOLERANCE. C IF THE CURRENT MODEL PREDICTS A MAXIMUM POSSIBLE FUNCTION C REDUCTION (SEE V(NREDUC)) OF AT MOST V(RFCTOL)*ABS(F0) AT C THE START OF THE CURRENT ITERATION, WHERE F0 IS THE C THEN CURRENT FUNCTION VALUE, AND IF THE LAST STEP ATTEMPT- C ED ACHIEVED NO MORE THAN TWICE THE PREDICTED FUNCTION C DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 4 (OR 5). C DEFAULT = MAX(10**-10, MACHEP**(2/3)), WHERE MACHEP IS C THE UNIT ROUNDOFF. C V(TUNER1)... V(26) HELPS DECIDE WHEN TO CHECK FOR FALSE CONVERGENCE C AND TO CONSIDER SWITCHING MODELS. THIS IS DONE IF THE C ACTUAL FUNCTION DECREASE FROM THE CURRENT STEP IS NO MORE C THAN V(TUNER1) TIMES ITS PREDICTED VALUE. DEFAULT = 0.1. C V(XCTOL).... V(33) IS THE X-CONVERGENCE TOLERANCE. IF A NEWTON STEP C (SEE V(NREDUC)) IS TRIED THAT HAS V(RELDX) .LE. V(XCTOL) C AND IF THIS STEP YIELDS AT MOST TWICE THE PREDICTED FUNC- C TION DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 3 (OR 5). C (SEE THE DESCRIPTION OF V(RELDX) BELOW.) C DEFAULT = MACHEP**0.5, WHERE MACHEP IS THE UNIT ROUNDOFF. C V(XFTOL).... V(34) IS THE FALSE CONVERGENCE TOLERANCE. IF A STEP IS C TRIED THAT GIVES NO MORE THAN V(TUNER1) TIMES THE PREDICT- C ED FUNCTION DECREASE AND THAT HAS V(RELDX) .LE. V(XFTOL), C AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, 6, OR C 7, THEN IT RETURNS WITH IV(1) = 8. (SEE THE DESCRIPTION C OF V(RELDX) BELOW.) DEFAULT = 100*MACHEP, WHERE C MACHEP IS THE UNIT ROUNDOFF. C V(*)........ DFAULT SUPPLIES TO V A NUMBER OF TUNING CONSTANTS, WITH C WHICH IT SHOULD ORDINARILY BE UNNECESSARY TO TINKER. SEE C VERSION 2.2 OF THE NL2SOL USAGE SUMMARY (WHICH IS AN C APPENDIX TO REF. 1). C C *** (SELECTED) V OUTPUT VALUES *** C C V(DGNORM)... V(1) IS THE 2-NORM OF (D**-1)*G, WHERE G IS THE MOST RE- C CENTLY COMPUTED GRADIENT AND D IS THE CORRESPONDING SCALE C VECTOR. C V(DSTNRM)... V(2) IS THE 2-NORM OF D*STEP, WHERE STEP IS THE MOST RE- C CENTLY COMPUTED STEP AND D IS THE CURRENT SCALE VECTOR. C V(F)........ V(10) IS THE CURRENT FUNCTION VALUE (HALF THE SUM OF C SQUARES). C V(F0)....... V(13) IS THE FUNCTION VALUE AT THE START OF THE CURRENT C ITERATION. C V(NREDUC)... V(6), IF POSITIVE, IS THE MAXIMUM FUNCTION REDUCTION C POSSIBLE ACCORDING TO THE CURRENT MODEL, I.E., THE FUNC- C TION REDUCTION PREDICTED FOR A NEWTON STEP (I.E., C STEP = -H**-1 * G, WHERE G = (J**T) * R IS THE CURRENT C GRADIENT AND H IS THE CURRENT HESSIAN APPROXIMATION -- C H = (J**T)*J FOR THE GAUSS-NEWTON MODEL AND C H = (J**T)*J + S FOR THE AUGMENTED MODEL). C V(NREDUC) = ZERO MEANS H IS NOT POSITIVE DEFINITE. C IF V(NREDUC) IS NEGATIVE, THEN IT IS THE NEGATIVE OF C THE FUNCTION REDUCTION PREDICTED FOR A STEP COMPUTED WITH C A STEP BOUND OF V(LMAX0) FOR USE IN TESTING FOR SINGULAR C CONVERGENCE. C V(PREDUC)... V(7) IS THE FUNCTION REDUCTION PREDICTED (BY THE CURRENT C QUADRATIC MODEL) FOR THE CURRENT STEP. THIS (DIVIDED BY C V(F0)) IS USED IN TESTING FOR RELATIVE FUNCTION C CONVERGENCE. C V(RELDX).... V(17) IS THE SCALED RELATIVE CHANGE IN X CAUSED BY THE C CURRENT STEP, COMPUTED AS C MAX(ABS(D(I)*(X(I)-X0(I)), 1 .LE. I .LE. P) / C MAX(D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P), C WHERE X = X0 + STEP. C C------------------------------- NOTES ------------------------------- C C *** ALGORITHM NOTES *** C C SEE REF. 1 FOR A DESCRIPTION OF THE ALGORITHM USED. C ON PROBLEMS WHICH ARE NATURALLY WELL SCALED, BETTER PERFORM- C ANCE MAY BE OBTAINED BY SETTING V(D0INIT) = 1.0 AND IV(DTYPE) = 0, C WHICH WILL CAUSE THE SCALE VECTOR D TO BE SET TO ALL ONES. C C *** USAGE NOTES *** C C AFTER A RETURN WITH IV(1) .LE. 11, IT IS POSSIBLE TO RESTART, C I.E., TO CHANGE SOME OF THE IV AND V INPUT VALUES DESCRIBED ABOVE C AND CONTINUE THE ALGORITHM FROM THE POINT WHERE IT WAS INTERRUPT- C ED. IV(1) SHOULD NOT BE CHANGED, NOR SHOULD ANY ENTRIES OF IV C AND V OTHER THAN THE INPUT VALUES (THOSE SUPPLIED BY DFAULT). C THOSE WHO DO NOT WISH TO WRITE A CALCJ WHICH COMPUTES THE JA- C COBIAN MATRIX ANALYTICALLY SHOULD CALL NL2SNO RATHER THAN NL2SOL. C NL2SNO USES FINITE DIFFERENCES TO COMPUTE AN APPROXIMATE JACOBIAN. C THOSE WHO WOULD PREFER TO PROVIDE R AND J (THE RESIDUAL AND C JACOBIAN) BY REVERSE COMMUNICATION RATHER THAN BY WRITING SUBROU- C TINES CALCR AND CALCJ MAY CALL ON NL2ITR DIRECTLY. SEE THE COM- C MENTS AT THE BEGINNING OF NL2ITR. C THOSE WHO USE NL2SOL INTERACTIVELY MAY WISH TO SUPPLY THEIR C OWN STOPX FUNCTION, WHICH SHOULD RETURN .TRUE. IF THE BREAK KEY C HAS BEEN PRESSED SINCE STOPX WAS LAST INVOKED. THIS MAKES IT POS- C SIBLE TO EXTERNALLY INTERRUPT NL2SOL (WHICH WILL RETURN WITH C IV(1) = 11 IF STOPX RETURNS .TRUE.). C STORAGE FOR J IS ALLOCATED AT THE END OF V. THUS THE CALLER C MAY MAKE V LONGER THAN SPECIFIED ABOVE AND MAY ALLOW CALCJ TO USE C ELEMENTS OF J BEYOND THE FIRST N*P AS SCRATCH STORAGE. C C *** PORTABILITY NOTES *** C C THE NL2SOL DISTRIBUTION TAPE CONTAINS BOTH SINGLE- AND DOUBLE- C PRECISION VERSIONS OF THE NL2SOL SOURCE CODE, SO IT SHOULD BE UN- C NECESSARY TO CHANGE PRECISIONS. C ONLY THE FUNCTIONS IMDCON AND RMDCON CONTAIN MACHINE-DEPENDENT C CONSTANTS. TO CHANGE FROM ONE MACHINE TO ANOTHER, IT SHOULD C SUFFICE TO CHANGE THE (FEW) RELEVANT LINES IN THESE FUNCTIONS. C INTRINSIC FUNCTIONS ARE EXPLICITLY DECLARED. ON CERTAIN COM- C PUTERS (E.G. UNIVAC), IT MAY BE NECESSARY TO COMMENT OUT THESE C DECLARATIONS. SO THAT THIS MAY BE DONE AUTOMATICALLY BY A SIMPLE C PROGRAM, SUCH DECLARATIONS ARE PRECEDED BY A COMMENT HAVING C/+ C IN COLUMNS 1-3 AND BLANKS IN COLUMNS 4-72 AND ARE FOLLOWED BY C A COMMENT HAVING C/ IN COLUMNS 1 AND 2 AND BLANKS IN COLUMNS 3-72. C THE NL2SOL SOURCE CODE IS EXPRESSED IN 1966 ANSI STANDARD C FORTRAN. IT MAY BE CONVERTED TO FORTRAN 77 BY C COMMENTING OUT ALL LINES THAT FALL BETWEEN A LINE HAVING C/6 IN C COLUMNS 1-3 AND A LINE HAVING C/7 IN COLUMNS 1-3 AND BY REMOVING C (I.E., REPLACING BY A BLANK) THE C IN COLUMN 1 OF THE LINES THAT C FOLLOW THE C/7 LINE AND PRECEED A LINE HAVING C/ IN COLUMNS 1-2 C AND BLANKS IN COLUMNS 3-72. THESE CHANGES CONVERT SOME DATA C STATEMENTS INTO PARAMETER STATEMENTS, CONVERT SOME VARIABLES FROM C REAL TO CHARACTER*4, AND MAKE THE DATA STATEMENTS THAT INITIALIZE C THESE VARIABLES USE CHARACTER STRINGS DELIMITED BY PRIMES INSTEAD C OF HOLLERITH CONSTANTS. (SUCH VARIABLES AND DATA STATEMENTS C APPEAR ONLY IN MODULES ITSMRY AND PARCHK. PARAMETER STATEMENTS C APPEAR NEARLY EVERYWHERE.) C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C C C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1979 - WINTER 1980). C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL ITSMRY, NL2ITR C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X. C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO- C RITHM. C LOGICAL STRTED INTEGER D1, J1, NF, R1 C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER D, J, NFCALL, NFGCAL, R, TOOBIG C C *** IV SUBSCRIPT VALUES *** C C/6 DATA NFCALL/6/, NFGCAL/7/, TOOBIG/2/ C/7 C PARAMETER (NFCALL=6, NFGCAL=7, TOOBIG=2) C/ C C *** V SUBSCRIPT VALUES *** C C/6 DATA D/27/, J/33/, R/50/ C/7 C PARAMETER (D=27, J=33, R=50) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C D1 = 94 + 2*N + P*(3*P + 31)/2 IV(D) = D1 R1 = D1 + P IV(R) = R1 J1 = R1 + N IV(J) = J1 STRTED = .TRUE. IF (IV(1) .NE. 0 .AND. IV(1) .NE. 12) GO TO 40 STRTED = .FALSE. IV(NFCALL) = 1 IV(NFGCAL) = 1 C 10 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM) IF (STRTED) GO TO 20 IF (NF .GT. 0) GO TO 30 IV(1) = 13 GO TO 60 C 20 IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 40 C 30 CALL CALCJ(N, P, X, IV(NFGCAL), V(J1), UIPARM, URPARM, UFPARM) IF (IV(NFGCAL) .EQ. 0) GO TO 50 STRTED = .TRUE. C 40 CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X) IF (IV(1) - 2) 10, 30, 999 C 50 IV(1) = 15 60 CALL ITSMRY(V(D1), IV, P, V, X) C 999 RETURN C *** LAST CARD OF NL2SOL FOLLOWS *** END SUBROUTINE NL2SNO(N, P, X, CALCR, IV, V, UIPARM, URPARM, UFPARM) SNO00010 C C *** LIKE NL2SOL, BUT WITHOUT CALCJ -- MINIMIZE NONLINEAR SUM OF *** C *** SQUARES USING FINITE-DIFFERENCE JACOBIAN APPROXIMATIONS *** C *** (NL2SOL VERSION 2.2) *** C INTEGER N, P, IV(1), UIPARM(1) REAL X(P), V(1), URPARM(1) C DIMENSION IV(60+P), V(93 + N*P + 3*N + P*(3*P+33)/2) EXTERNAL CALCR, UFPARM C C----------------------------- DISCUSSION ---------------------------- C C THE PARAMETERS FOR NL2SNO ARE THE SAME AS THOSE FOR NL2SOL C (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED. INSTEAD OF CALLING C CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, NL2SNO COMPUTES C AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE C V(DLTFDJ) BELOW. NL2SNO USES FUNCTION VALUES ONLY WHEN COMPUT- C THE COVARIANCE MATRIX (RATHER THAN THE FUNCTIONS AND GRADIENTS C THAT NL2SOL MAY USE). TO DO SO, NL2SNO SETS IV(COVREQ) TO -1 IF C IV(COVPRT) = 1 WITH IV(COVREQ) = 0 AND TO MINUS ITS ABSOLUTE C VALUE OTHERWISE. THUS V(DELTA0) IS NEVER REFERENCED AND ONLY C V(DLTFDC) MATTERS -- SEE NL2SOL FOR A DESCRIPTION OF V(DLTFDC). C THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO- C BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION C COUNT IV(NFCALL) AND ARE NOT OTHERWISE REPORTED. C C V(DLTFDJ)... V(36) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE C FINITE-DIFFERENCE JACOBIAN MATRIX. FOR DIFFERENCES IN- C VOLVING X(I), THE STEP SIZE FIRST TRIED IS C V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)), C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF C THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN C SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE- C LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF. C DEFAULT = MACHEP**0.5. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS REAL ABS, AMAX1 C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL DFAULT, ITSMRY, NL2ITR, RMDCON, VSCOPY REAL RMDCON C C DFAULT... SUPPLIES DEFAULT PARAMETER VALUES. C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X. C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO- C RITHM. C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS. C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C LOGICAL STRTED INTEGER DK, D1, I, J1, J1K, K, NF, RN, R1, DINIT REAL H, HFAC, HLIM, NEGPT5, ONE, XK, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVPRT, COVREQ, D, DLTFDJ, DTYPE, J, NFCALL, NFGCAL, R, 1 TOOBIG C C/6 DATA HFAC/1.E+3/, NEGPT5/-0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/ C/7 C PARAMETER (HFAC=1.D+3, NEGPT5=-0.5D+0, ONE=1.D+0, ZERO=0.D+0) C/ C C *** IV SUBSCRIPT VALUES *** C C/6 DATA COVPRT/14/, COVREQ/15/, D/27/, DTYPE/16/, J/33/, 1 NFCALL/6/, NFGCAL/7/, R/50/, TOOBIG/2/ C/7 C PARAMETER (COVPRT=14, COVREQ=15, D=27, DTYPE=16, J=33, C 1 NFCALL=6, NFGCAL=7, R=50, TOOBIG=2) C/ C C *** V SUBSCRIPT VALUES *** C C/6 DATA DLTFDJ/36/, DINIT/38/ C/7 C PARAMETER (DLTFDJ=36) C SAVE HLIM C/ DATA HLIM/0.E+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C D1 = 94 + 2*N + P*(3*P + 31)/2 IV(D) = D1 R1 = D1 + P IV(R) = R1 J1 = R1 + N IV(J) = J1 RN = J1 - 1 IF (IV(1) .EQ. 0) CALL DFAULT(IV, V) IV(COVREQ) = -IABS(IV(COVREQ)) IF (IV(COVPRT) .NE. 0 .AND. IV(COVREQ) .EQ. 0) IV(COVREQ) = -1 STRTED = .TRUE. IF (IV(1) .NE. 12) GO TO 80 STRTED = .FALSE. IV(NFCALL) = 1 IV(NFGCAL) = 1 C *** INITIALIZE SCALE VECTOR D TO ONES FOR COMPUTING C *** INITIAL JACOBIAN. IF (IV(DTYPE) .GT. 0) CALL VSCOPY(P, V(D1), ONE) IF (V(DINIT).GT.ZERO) CALL VSCOPY(P, V(D1), V(DINIT)) C 10 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM) IF (STRTED) GO TO 20 IF (NF .GT. 0) GO TO 30 IV(1) = 13 GO TO 90 C 20 IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 80 C C *** COMPUTE FINITE-DIFFERENCE JACOBIAN *** C 30 J1K = J1 DK = D1 DO 70 K = 1, P XK = X(K) H = V(DLTFDJ) * AMAX1(ABS(XK), ONE/V(DK)) DK = DK + 1 40 X(K) = XK + H NF = IV(NFGCAL) CALL CALCR (N, P, X, NF, V(J1K), UIPARM, URPARM, UFPARM) IF (NF .GT. 0) GO TO 50 IF (HLIM .EQ. ZERO) HLIM = HFAC * RMDCON(3) C *** HLIM = HFAC TIMES THE UNIT ROUNDOFF *** H = NEGPT5 * H IF (ABS(H) .GE. HLIM) GO TO 40 IV(1) = 15 GO TO 90 50 X(K) = XK DO 60 I = R1, RN V(J1K) = (V(J1K) - V(I)) / H J1K = J1K + 1 60 CONTINUE 70 CONTINUE C STRTED = .TRUE. C 80 CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X) IF (IV(1) - 2) 10, 30, 999 C 90 CALL ITSMRY(V(D1), IV, P, V, X) C 999 RETURN C *** LAST CARD OF NL2SNO FOLLOWS *** END SUBROUTINE NL2ITR (D, IV, J, N, NN, P, R, V, X) ITR00010 C C *** CARRY OUT NL2SOL (NONLINEAR LEAST-SQUARES) ITERATIONS *** C *** (NL2SOL VERSION 2.2) *** C C *** PARAMETER DECLARATIONS *** C INTEGER IV(1), N, NN, P REAL D(P), J(NN,P), R(N), V(1), X(P) C DIMENSION IV(60+P), V(93 + 2*N + P*(3*P+31)/2) C C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C IV... INTEGER VALUE ARRAY. C J.... N BY P JACOBIAN MATRIX (LEAD DIMENSION NN). C N.... NUMBER OF OBSERVATIONS (COMPONENTS IN R). C NN... LEAD DIMENSION OF J. C P.... NUMBER OF PARAMETERS (COMPONENTS IN X). C R.... RESIDUAL VECTOR. C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C C *** DISCUSSION *** C C PARAMETERS IV, N, P, V, AND X ARE THE SAME AS THE CORRESPOND- C ING ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER C (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS C NOT NEEDED). MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE C TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, C AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). THE VALUES IV(D), C IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND C NL2SNO), ARE NOT REFERENCED BY NL2ITR OR THE SUBROUTINES IT CALLS. C ON A FRESH START, I.E., A CALL ON NL2ITR WITH IV(1) = 0 OR 12, C NL2ITR ASSUMES THAT R = R(X), THE RESIDUAL AT X, AND J = J(X), C THE CORRESPONDING JACOBIAN MATRIX OF R AT X. C C IV(1) = 1 MEANS THE CALLER SHOULD SET R TO R(X), THE RESIDUAL AT X, C AND CALL NL2ITR AGAIN, HAVING CHANGED NONE OF THE OTHER C PARAMETERS. AN EXCEPTION OCCURS IF R CANNOT BE EVALUATED C AT X (E.G. IF R WOULD OVERFLOW), WHICH MAY HAPPEN BECAUSE C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE NL2ITR TO IG- C NORE R AND TRY A SMALLER STEP. THE PARAMETER NF THAT C NL2SOL PASSES TO CALCR (FOR POSSIBLE USE BY CALCJ) IS A C COPY OF IV(NFCALL) = IV(6). C IV(1) = 2 MEANS THE CALLER SHOULD SET J TO J(X), THE JACOBIAN MATRIX C OF R AT X, AND CALL NL2ITR AGAIN. THE CALLER MAY CHANGE C D AT THIS TIME, BUT SHOULD NOT CHANGE ANY OF THE OTHER C PARAMETERS. THE PARAMETER NF THAT NL2SOL PASSES TO C CALCJ IS IV(NFGCAL) = IV(7). IF J CANNOT BE EVALUATED C AT X, THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN WHICH C CASE NL2ITR WILL RETURN WITH IV(1) = 15. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C (SEE NL2SOL FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DUMMY, DIG1, G1, G01, H0, H1, I, IM1, IPIVI, IPIVK, IPIV1, 1 IPK, K, KM1, L, LKY1, LMAT1, LSTGST, M, PP1O2, QTR1, 2 RDK, RD0, RD1, RSAVE1, SMH, SSTEP, STEP1, STPMOD, S1, 3 TEMP1, TEMP2, W1, X01 REAL E, RDOF1, STTSST, T, T1 C C *** CONSTANTS *** C REAL HALF, NEGONE, ONE, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS REAL ABS C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL ASSESS, COVCLC, DOTPRD, DUPDAT, GQTSTP, ITSMRY, LMSTEP, 1 PARCHK, QAPPLY, QRFACT, RPTMUL, SLUPDT, SLVMUL, STOPX, 2 VAXPY, VCOPY, VSCOPY, V2NORM LOGICAL STOPX REAL DOTPRD, V2NORM C C ASSESS... ASSESSES CANDIDATE STEP. C COVCLC... COMPUTES COVARIANCE MATRIX. C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS. C DUPDAT... UPDATES SCALE VECTOR D. C GQTSTP... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL). C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X. C LMSTEP... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL). C PARCHK... CHECKS VALIDITY OF INPUT IV AND V VALUES. C QAPPLY... APPLIES ORTHOGONAL MATRIX Q FROM QRFACT TO A VECTOR. C QRFACT... COMPUTES QR DECOMPOSITION OF A MATRIX VIA HOUSEHOLDER TRANS. C RPTMUL... MULTIPLIES VECTOR BY THE R MATRIX (AND/OR ITS TRANSPOSE) C STORED BY QRFACT. C SLUPDT... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI- C ANGLE OF A SYMMETRIC MATRIX. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C VAXPY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C VCOPY.... COPIES ONE VECTOR TO ANOTHER. C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V2NORM... RETURNS THE 2-NORM OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COSMIN, COVMAT, COVPRT, COVREQ, DGNORM, DIG, 1 DINIT, DSTNRM, DTYPE, D0INIT, F, FDIF, FUZZ, 2 F0, G, GTSTEP, H, IERR, INCFAC, INITS, IPIVOT, IPIV0, IRC, 3 JTINIT, JTOL1, KAGQT, KALM, LKY, LMAT, LMAX0, MODE, MODEL, 4 MXFCAL, MXITER, NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL, 5 NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC, RADINC, 6 RADIUS, RAD0, RD, RESTOR, RLIMIT, RSAVE, S, SIZE, STEP, 7 STGLIM, STLSTG, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4, 8 TUNER5, VSAVE1, W, WSCALE, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C/6 DATA CNVCOD/34/, COVMAT/26/, COVPRT/14/, 1 COVREQ/15/, DIG/43/, DTYPE/16/, G/28/, H/44/, 2 IERR/32/, INITS/25/, IPIVOT/61/, IPIV0/60/, 3 IRC/3/, KAGQT/35/, KALM/36/, LKY/37/, LMAT/58/, 4 MODE/38/, MODEL/5/, MXFCAL/17/, MXITER/18/, 5 NFCALL/6/, NFGCAL/7/, NFCOV/40/, NGCOV/41/, 6 NGCALL/30/, NITER/31/, QTR/49/, 7 RADINC/8/, RD/51/, RESTOR/9/, RSAVE/52/, S/53/, 8 STEP/55/, STGLIM/11/, STLSTG/56/, SUSED/57/, 9 SWITCH/12/, TOOBIG/2/, W/59/, XIRC/13/, X0/60/ C/7 C PARAMETER (CNVCOD=34, COVMAT=26, COVPRT=14, C 1 COVREQ=15, DIG=43, DTYPE=16, G=28, H=44, C 2 IERR=32, INITS=25, IPIVOT=61, IPIV0=60, C 3 IRC=3, KAGQT=35, KALM=36, LKY=37, LMAT=58, C 4 MODE=38, MODEL=5, MXFCAL=17, MXITER=18, C 5 NFCALL=6, NFGCAL=7, NFCOV=40, NGCOV=41, C 6 NGCALL=30, NITER=31, QTR=49, C 7 RADINC=8, RD=51, RESTOR=9, RSAVE=52, S=53, C 8 STEP=55, STGLIM=11, STLSTG=56, SUSED=57, C 9 SWITCH=12, TOOBIG=2, W=59, XIRC=13, X0=60) C/ C C *** V SUBSCRIPT VALUES *** C C/6 DATA COSMIN/43/, DGNORM/1/, DINIT/38/, DSTNRM/2/, 1 D0INIT/37/, F/10/, FDIF/11/, FUZZ/45/, 2 F0/13/, GTSTEP/4/, INCFAC/23/, 3 JTINIT/39/, JTOL1/87/, LMAX0/35/, 4 NVSAVE/9/, PHMXFC/21/, PREDUC/7/, 5 RADFAC/16/, RADIUS/8/, RAD0/9/, RLIMIT/42/, 6 SIZE/47/, STPPAR/5/, TUNER4/29/, TUNER5/30/, 7 VSAVE1/78/, WSCALE/48/ C/7 C PARAMETER (COSMIN=43, DGNORM=1, DINIT=38, DSTNRM=2, C 1 D0INIT=37, F=10, FDIF=11, FUZZ=45, C 2 F0=13, GTSTEP=4, INCFAC=23, C 3 JTINIT=39, JTOL1=87, LMAX0=35, C 4 NVSAVE=9, PHMXFC=21, PREDUC=7, C 5 RADFAC=16, RADIUS=8, RAD0=9, RLIMIT=42, C 6 SIZE=47, STPPAR=5, TUNER4=29, TUNER5=30, C 7 VSAVE1=78, WSCALE=48) C/ C C C/6 DATA HALF/0.5E+0/, NEGONE/-1.E+0/, ONE/1.E+0/, ZERO/0.E+0/ C/7 C PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 20 IF (I .EQ. 2) GO TO 50 C C *** CHECK VALIDITY OF IV AND V INPUT VALUES *** C C *** NOTE -- IF IV(1) = 0, THEN PARCHK CALLS DFAULT(IV, V) *** CALL PARCHK(IV, N, NN, P, V) I = IV(1) - 2 IF (I .GT. 10) GO TO 999 GO TO (350, 350, 350, 350, 350, 350, 195, 160, 195, 10), I C C *** INITIALIZATION AND STORAGE ALLOCATION *** C 10 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(STGLIM) = 2 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(COVMAT) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(KALM) = -1 IV(RADINC) = 0 IV(S) = JTOL1 + 2*P PP1O2 = P * (P + 1) / 2 IV(X0) = IV(S) + PP1O2 IV(STEP) = IV(X0) + P IV(STLSTG) = IV(STEP) + P IV(DIG) = IV(STLSTG) + P IV(G) = IV(DIG) + P IV(LKY) = IV(G) + P IV(RD) = IV(LKY) + P IV(RSAVE) = IV(RD) + P IV(QTR) = IV(RSAVE) + N IV(H) = IV(QTR) + N IV(W) = IV(H) + PP1O2 IV(LMAT) = IV(W) + 4*P + 7 C +++ LENGTH OF W = P*(P+9)/2 + 7. LMAT IS CONTAINED IN W. IF (V(DINIT) .GE. ZERO) CALL VSCOPY(P, D, V(DINIT)) IF (V(JTINIT) .GT. ZERO) CALL VSCOPY(P, V(JTOL1), V(JTINIT)) I = JTOL1 + P IF (V(D0INIT) .GT. ZERO) CALL VSCOPY(P, V(I), V(D0INIT)) V(RAD0) = ZERO V(STPPAR) = ZERO V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C C *** SET INITIAL MODEL AND S MATRIX *** C IV(MODEL) = 1 IF (IV(INITS) .EQ. 2) IV(MODEL) = 2 S1 = IV(S) IF (IV(INITS) .EQ. 0) CALL VSCOPY(PP1O2, V(S1), ZERO) C C *** COMPUTE FUNCTION VALUE (HALF THE SUM OF SQUARES) *** C 20 T = V2NORM(N, R) IF (T .GT. V(RLIMIT)) IV(TOOBIG) = 1 IF (IV(TOOBIG) .NE. 0) GO TO 30 V(F) = HALF * T**2 30 IF (IV(MODE)) 40, 350, 730 C 40 IF (IV(TOOBIG) .EQ. 0) GO TO 60 IV(1) = 13 GO TO 900 C C *** MAKE SURE JACOBIAN COULD BE COMPUTED *** C 50 IF (IV(NFGCAL) .NE. 0) GO TO 60 IV(1) = 15 GO TO 900 C C *** COMPUTE GRADIENT *** C 60 IV(KALM) = -1 G1 = IV(G) DO 70 I = 1, P V(G1) = DOTPRD(N, R, J(1,I)) G1 = G1 + 1 70 CONTINUE IF (IV(MODE) .GT. 0) GO TO 710 C C *** UPDATE D AND MAKE COPIES OF R FOR POSSIBLE USE LATER *** C IF (IV(DTYPE) .GT. 0) CALL DUPDAT(D, IV, J, N, NN, P, V) RSAVE1 = IV(RSAVE) CALL VCOPY(N, V(RSAVE1), R) QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) C C *** COMPUTE D**-1 * GRADIENT *** C G1 = IV(G) DIG1 = IV(DIG) K = DIG1 DO 80 I = 1, P V(K) = V(G1) / D(I) K = K + 1 G1 = G1 + 1 80 CONTINUE V(DGNORM) = V2NORM(P, V(DIG1)) C IF (IV(CNVCOD) .NE. 0) GO TO 700 IF (IV(MODE) .EQ. 0) GO TO 570 IV(MODE) = 0 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 150 CALL ITSMRY(D, IV, P, V, X) 160 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 170 IV(1) = 10 GO TO 900 170 IV(NITER) = K + 1 C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 185 STEP1 = IV(STEP) DO 180 I = 1, P V(STEP1) = D(I) * V(STEP1) STEP1 = STEP1 + 1 180 CONTINUE STEP1 = IV(STEP) V(RADIUS) = V(RADFAC) * V2NORM(P, V(STEP1)) C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 185 X01 = IV(X0) V(F0) = V(F) IV(KAGQT) = -1 IV(IRC) = 4 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(MODEL) C C *** COPY X TO X0 *** C CALL VCOPY(P, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 190 IF (.NOT. STOPX(DUMMY)) GO TO 200 IV(1) = 11 GO TO 205 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 195 IF (V(F) .GE. V(F0)) GO TO 200 V(RADFAC) = ONE K = IV(NITER) GO TO 170 C 200 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 210 IV(1) = 9 205 IF (V(F) .GE. V(F0)) GO TO 900 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 560 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 210 STEP1 = IV(STEP) W1 = IV(W) IF (IV(MODEL) .EQ. 2) GO TO 240 C C *** COMPUTE LEVENBERG-MARQUARDT STEP *** C QTR1 = IV(QTR) IF (IV(KALM) .GE. 0) GO TO 215 RD1 = IV(RD) IF (-1 .EQ. IV(KALM)) CALL QRFACT(NN, N, P, J, V(RD1), 1 IV(IPIVOT), IV(IERR), 0, V(W1)) CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR)) 215 H1 = IV(H) IF (H1 .GT. 0) GO TO 230 C C *** COPY R MATRIX TO H *** C H1 = -H1 IV(H) = H1 K = H1 RD1 = IV(RD) V(K) = V(RD1) IF (P .EQ. 1) GO TO 230 DO 220 I = 2, P CALL VCOPY(I-1, V(K+1), J(1,I)) K = K + I RD1 = RD1 + 1 V(K) = V(RD1) 220 CONTINUE C 230 G1 = IV(G) CALL LMSTEP(D, V(G1), IV(IERR), IV(IPIVOT), IV(KALM), P, 1 V(QTR1), V(H1), V(STEP1), V, V(W1)) GO TO 310 C C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL) *** C 240 IF (IV(H) .GT. 0) GO TO 300 C C *** SET H TO D**-1 * ( (J**T)*J + S) ) * D**-1. *** C H1 = -IV(H) IV(H) = H1 S1 = IV(S) IF (-1 .NE. IV(KALM)) GO TO 270 C C *** J IS IN ITS ORIGINAL FORM *** C DO 260 I = 1, P T = ONE / D(I) DO 250 K = 1, I V(H1) = T*(DOTPRD(N,J(1,I),J(1,K))+V(S1)) / D(K) H1 = H1 + 1 S1 = S1 + 1 250 CONTINUE 260 CONTINUE GO TO 300 C C *** LMSTEP HAS APPLIED QRFACT TO J *** C 270 SMH = S1 - H1 H0 = H1 - 1 IPIV1 = IV(IPIVOT) T1 = ONE / D(IPIV1) RD0 = IV(RD) - 1 RDOF1 = V(RD0 + 1) DO 290 I = 1, P L = IPIV0 + I IPIVI = IV(L) H1 = H0 + IPIVI*(IPIVI-1)/2 L = H1 + IPIVI M = L + SMH C *** V(L) = H(IPIVOT(I), IPIVOT(I)) *** C *** V(M) = S(IPIVOT(I), IPIVOT(I)) *** T = ONE / D(IPIVI) RDK = RD0 + I E = V(RDK)**2 IF (I .GT. 1) E = E + DOTPRD(I-1, J(1,I), J(1,I)) V(L) = (E + V(M)) * T**2 IF (I .EQ. 1) GO TO 290 L = H1 + IPIV1 IF (IPIVI .LT. IPIV1) L = L + 1 ((IPIV1-IPIVI)*(IPIV1+IPIVI-3))/2 M = L + SMH C *** V(L) = H(IPIVOT(I), IPIVOT(1)) *** C *** V(M) = S(IPIVOT(I), IPIVOT(1)) *** V(L) = T * (RDOF1 * J(1,I) + V(M)) * T1 IF (I .EQ. 2) GO TO 290 IM1 = I - 1 DO 280 K = 2, IM1 IPK = IPIV0 + K IPIVK = IV(IPK) L = H1 + IPIVK IF (IPIVI .LT. IPIVK) L = L + 1 ((IPIVK-IPIVI)*(IPIVK+IPIVI-3))/2 M = L + SMH C *** V(L) = H(IPIVOT(I), IPIVOT(K)) *** C *** V(M) = S(IPIVOT(I), IPIVOT(K)) *** KM1 = K - 1 RDK = RD0 + K V(L) = T * (DOTPRD(KM1, J(1,I), J(1,K)) + 1 V(RDK)*J(K,I) + V(M)) / D(IPIVK) 280 CONTINUE 290 CONTINUE C C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP *** C 300 H1 = IV(H) DIG1 = IV(DIG) LMAT1 = IV(LMAT) CALL GQTSTP(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1), 1 V, V(W1)) C C C *** COMPUTE R(X0 + STEP) *** C 310 IF (IV(IRC) .EQ. 6) GO TO 350 X01 = IV(X0) STEP1 = IV(STEP) CALL VAXPY(P, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 IV(TOOBIG) = 0 GO TO 999 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 350 STEP1 = IV(STEP) LSTGST = IV(STLSTG) X01 = IV(X0) CALL ASSESS(D, IV, P, V(STEP1), V(LSTGST), V, X, V(X01)) C C *** IF NECESSARY, SWITCH MODELS AND/OR RESTORE R *** C IF (IV(SWITCH) .EQ. 0) GO TO 360 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 CALL VCOPY(NVSAVE, V, V(VSAVE1)) 360 IF (IV(RESTOR) .EQ. 0) GO TO 390 RSAVE1 = IV(RSAVE) CALL VCOPY(N, R, V(RSAVE1)) 390 L = IV(IRC) - 4 STPMOD = IV(MODEL) IF (L .GT. 0) GO TO (410,440,450,450,450,450,450,450,640,570), L C C *** DECIDE WHETHER TO CHANGE MODELS *** C E = V(PREDUC) - V(FDIF) SSTEP = IV(LKY) S1 = IV(S) CALL SLVMUL(P, V(SSTEP), V(S1), V(STEP1)) STTSST = HALF * DOTPRD(P, V(STEP1), V(SSTEP)) IF (IV(MODEL) .EQ. 1) STTSST = -STTSST IF (ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 400 C C *** SWITCH MODELS *** C IV(MODEL) = 3 - IV(MODEL) IF (IV(MODEL) .EQ. 1) IV(KAGQT) = -1 IF (IV(MODEL) .EQ. 2 .AND. IV(KALM) .GT. 0) IV(KALM) = 0 IF (-2 .LT. L) GO TO 480 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 CALL VCOPY(NVSAVE, V(VSAVE1), V) GO TO 420 C 400 IF (-3 .LT. L) GO TO 480 C C *** RECOMPUTE STEP WITH DECREASED RADIUS *** C V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 190 C C *** RECOMPUTE STEP, SAVING V VALUES AND R IF NECESSARY *** C 410 V(RADIUS) = V(RADFAC) * V(DSTNRM) 420 IF (V(F) .GE. V(F0)) GO TO 190 RSAVE1 = IV(RSAVE) CALL VCOPY(N, V(RSAVE1), R) GO TO 190 C C *** COMPUTE STEP OF LENGTH V(LMAX0) FOR SINGULAR CONVERGENCE TEST C 440 V(RADIUS) = V(LMAX0) GO TO 210 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 450 IV(CNVCOD) = L IF (V(F) .GE. V(F0)) GO TO 700 IF (IV(XIRC) .EQ. 14) GO TO 700 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 480 IV(COVMAT) = 0 C C *** SET LKY = (J(X0)**T) * R(X) *** C LKY1 = IV(LKY) IF (IV(KALM) .GE. 0) GO TO 500 C C *** JACOBIAN HAS NOT BEEN MODIFIED *** C DO 490 I = 1, P V(LKY1) = DOTPRD(N, J(1,I), R) LKY1 = LKY1 + 1 490 CONTINUE GO TO 510 C C *** QRFACT HAS BEEN APPLIED TO J. STORE COPY OF R IN QTR AND *** C *** APPLY Q TO IT. *** C 500 QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR)) C C *** MULTIPLY TOP P-VECTOR IN QTR BY PERMUTED UPPER TRIANGLE *** C *** STORED BY QRFACT IN J AND RD. *** C RD1 = IV(RD) TEMP1 = IV(STLSTG) CALL RPTMUL(3, IV(IPIVOT), J, NN, P, V(RD1), V(QTR1), V(LKY1), 1 V(TEMP1)) C C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS *** C 510 IF (IV(IRC) .NE. 3) GO TO 560 STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(X0) C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C IF (STPMOD .EQ. 2) GO TO 530 C C *** STEP COMPUTED USING GAUSS-NEWTON MODEL *** C *** -- QRFACT HAS BEEN APPLIED TO J *** C RD1 = IV(RD) CALL RPTMUL(2, IV(IPIVOT), J, NN, P, V(RD1), 1 V(STEP1), V(TEMP1), V(TEMP2)) GO TO 560 C C *** STEP COMPUTED USING AUGMENTED MODEL *** C 530 H1 = IV(H) K = TEMP2 DO 540 I = 1, P V(K) = D(I) * V(STEP1) K = K + 1 STEP1 = STEP1 + 1 540 CONTINUE CALL SLVMUL(P, V(TEMP1), V(H1), V(TEMP2)) DO 550 I = 1, P V(TEMP1) = D(I) * V(TEMP1) TEMP1 = TEMP1 + 1 550 CONTINUE C C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE *** C 560 IV(NGCALL) = IV(NGCALL) + 1 G1 = IV(G) G01 = IV(W) CALL VCOPY(P, V(G01), V(G1)) IV(1) = 2 GO TO 999 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 570 G01 = IV(W) G1 = IV(G) CALL VAXPY(P, V(G01), NEGONE, V(G01), V(G1)) STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(X0) IF (IV(IRC) .NE. 3) GO TO 600 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) *** C K = TEMP1 L = G01 DO 580 I = 1, P V(K) = (V(K) - V(L)) / D(I) K = K + 1 L = L + 1 580 CONTINUE C C *** DO GRADIENT TESTS *** C IF (V2NORM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 590 IF (DOTPRD(P, V(G1), V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 600 590 V(RADFAC) = V(INCFAC) C C *** FINISH COMPUTING LKY = ((J(X) - J(X0))**T) * R *** C C *** CURRENTLY LKY = (J(X0)**T) * R *** C 600 LKY1 = IV(LKY) CALL VAXPY(P, V(LKY1), NEGONE, V(LKY1), V(G1)) C C *** DETERMINE SIZING FACTOR V(SIZE) *** C C *** SET TEMP1 = S * STEP *** S1 = IV(S) CALL SLVMUL(P, V(TEMP1), V(S1), V(STEP1)) C T1 = ABS(DOTPRD(P, V(STEP1), V(TEMP1))) T = ABS(DOTPRD(P, V(STEP1), V(LKY1))) V(SIZE) = ONE IF (T .LT. T1) V(SIZE) = T / T1 C C *** UPDATE S *** C CALL SLUPDT(V(S1), V(COSMIN), P, V(SIZE), V(STEP1), V(TEMP1), 1 V(TEMP2), V(G01), V(WSCALE), V(LKY1)) IV(1) = 2 GO TO 150 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 640 IV(1) = 14 GO TO 900 C C *** CONVERGENCE OBTAINED -- COMPUTE COVARIANCE MATRIX IF DESIRED *** C 700 IF (IV(COVREQ) .EQ. 0 .AND. IV(COVPRT) .EQ. 0) GO TO 760 IF (IV(COVMAT) .NE. 0) GO TO 760 IF (IV(CNVCOD) .GE. 7) GO TO 760 IV(MODE) = 0 710 CALL COVCLC(I, D, IV, J, N, NN, P, R, V, X) GO TO (720, 720, 740, 750), I 720 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(RESTOR) = I IV(1) = 1 GO TO 999 C 730 IF (IV(RESTOR) .EQ. 1 .OR. IV(TOOBIG) .NE. 0) GO TO 710 IV(NFGCAL) = IV(NFCALL) 740 IV(NGCOV) = IV(NGCOV) + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(1) = 2 GO TO 999 C 750 IV(MODE) = 0 IF (IV(NITER) .EQ. 0) IV(MODE) = -1 C 760 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 900 CALL ITSMRY(D, IV, P, V, X) C 999 RETURN C C *** LAST CARD OF NL2ITR FOLLOWS *** END SUBROUTINE ASSESS (D, IV, P, STEP, STLSTG, V, X, X0) ASS00010 C C *** ASSESS CANDIDATE STEP (NL2SOL VERSION 2.2) *** C INTEGER P, IV(13) REAL D(P), STEP(P), STLSTG(P), V(35), X(P), X0(P) C C *** PURPOSE *** C C THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION C ROUTINE TO ASSESS THE NEXT CANDIDATE STEP. IT MAY RECOMMEND ONE C OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM- C PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE C TO CONVERGENCE OR FALSE CONVERGENCE. SEE THE RETURN CODE LISTING C BELOW. C C-------------------------- PARAMETER USAGE -------------------------- C C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF IV VALUES REFERENCED. C D (IN) SCALE VECTOR USED IN COMPUTING V(RELDX) -- SEE BELOW. C P (IN) NUMBER OF PARAMETERS BEING OPTIMIZED. C STEP (I/O) ON INPUT, STEP IS THE STEP TO BE ASSESSED. IT IS UN- C CHANGED ON OUTPUT UNLESS A PREVIOUS STEP ACHIEVED A C BETTER OBJECTIVE FUNCTION REDUCTION, IN WHICH CASE STLSTG C WILL HAVE BEEN COPIED TO STEP. C STLSTG (I/O) WHEN ASSESS RECOMMENDS RECOMPUTING STEP EVEN THOUGH THE C CURRENT (OR A PREVIOUS) STEP YIELDS AN OBJECTIVE FUNC- C TION DECREASE, IT SAVES IN STLSTG THE STEP THAT GAVE THE C BEST FUNCTION REDUCTION SEEN SO FAR (IN THE CURRENT ITERA- C TION). IF THE RECOMPUTED STEP YIELDS A LARGER FUNCTION C VALUE, THEN STEP IS RESTORED FROM STLSTG AND C X = X0 + STEP IS RECOMPUTED. C V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF V VALUES REFERENCED. C X (I/O) ON INPUT, X = X0 + STEP IS THE POINT AT WHICH THE OBJEC- C TIVE FUNCTION HAS JUST BEEN EVALUATED. IF AN EARLIER C STEP YIELDED A BIGGER FUNCTION DECREASE, THEN X IS C RESTORED TO THE CORRESPONDING EARLIER VALUE. OTHERWISE, C IF THE CURRENT STEP DOES NOT GIVE ANY FUNCTION DECREASE, C THEN X IS RESTORED TO X0. C X0 (IN) INITIAL OBJECTIVE FUNCTION PARAMETER VECTOR (AT THE C START OF THE CURRENT ITERATION). C C *** IV VALUES REFERENCED *** C C IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION, C IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS C SET WHEN STEP IS DEFINITELY TO BE ACCEPTED). ON INPUT C AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE C UNCHANGED SINCE THE PREVIOUS RETURN OF ASSESS. C ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE C FOLLOWING VALUES... C 1 = SWITCH MODELS OR TRY SMALLER STEP. C 2 = SWITCH MODELS OR ACCEPT STEP. C 3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT C TESTS. C 4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED. C 5 = RECOMPUTE STEP (USING THE SAME MODEL). C 6 = RECOMPUTE STEP WITH RADIUS = V(LMAX0) BUT DO NOT C EVAULATE THE OBJECTIVE FUNCTION. C 7 = X-CONVERGENCE (SEE V(XCTOL)). C 8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)). C 9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE. C 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)). C 11 = SINGULAR CONVERGENCE (SEE V(LMAX0)). C 12 = FALSE CONVERGENCE (SEE V(XFTOL)). C 13 = IV(IRC) WAS OUT OF RANGE ON INPUT. C RETURN CODE I HAS PRECDENCE OVER I+1 FOR I = 9, 10, 11. C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL). C IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING C THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION. C IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION, C THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT. C IV(NFCALL) (IN) INVOCATION COUNT FOR THE OBJECTIVE FUNCTION. C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST C FUNCTION REDUCTION THIS ITERATION. IV(NFGCAL) REMAINS C UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED. C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER C OF DECREASES) SO FAR THIS ITERATION. C IV(RESTOR) (OUT) SET TO 0 UNLESS X AND V(F) HAVE BEEN RESTORED, IN C WHICH CASE ASSESS SETS IV(RESTOR) = 1. C IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE C CURRENT ITERATION. C IV(STGLIM) (IN) MAXIMUM NUMBER OF MODELS TO CONSIDER. C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT C GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL, C IN WHICH CASE ASSESS SETS IV(SWITCH) = 1. C IV(TOOBIG) (IN) IS NONZERO IF STEP WAS TOO BIG (E.G. IF IT CAUSED C OVERFLOW). C IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF C CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS. C C *** V VALUES REFERENCED *** C C V(AFCTOL) (IN) ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. IF THE C ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS C THAN V(AFCTOL), THEN ASSESS RETURNS WITH IV(IRC) = 10. C V(DECFAC) (IN) FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS C NONZERO. C V(DSTNRM) (IN) THE 2-NORM OF D*STEP. C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP. C V(DST0) (IN) THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED, C I.E., FOR V(NREDUC) .GE. 0). C V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC- C TION VALUE AT X. IF X IS RESTORED TO A PREVIOUS VALUE, C THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE. C V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT C VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION C DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE). C V(FLSTGD) (I/O) SAVED VALUE OF V(F). C V(F0) (IN) OBJECTIVE FUNCTION VALUE AT START OF ITERATION. C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP. C V(GTSTEP) (IN) INNER PRODUCT BETWEEN STEP AND GRADIENT. C V(INCFAC) (IN) MINIMUM FACTOR BY WHICH TO INCREASE RADIUS. C V(LMAX0) (IN) MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND). C IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE C WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, 9, C OR 10 DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAX0), AND IF C V(PREDUC) .LE. V(RFCTOL) * ABS(V(F0)), THEN ASSESS RE- C TURNS WITH IV(IRC) = 11. IF SO DOING APPEARS WORTHWHILE, C THEN ASSESS REPEATS THIS TEST WITH V(PREDUC) COMPUTED FOR C A STEP OF LENGTH V(LMAX0) (BY A RETURN WITH IV(IRC) = 6). C V(NREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C NEWTON STEP. IF ASSESS IS CALLED WITH IV(IRC) = 6, I.E., C IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAX0) FOR C USE IN THE SINGULAR CONVERVENCE TEST, THEN V(NREDUC) IS C SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED. C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP. C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C CURRENT STEP. C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS, C WHICH SHOULD BE V(RADFAC)*DST, WHERE DST IS EITHER THE C OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF C DIAG(NEWD)*STEP FOR THE OUTPUT VALUE OF STEP AND THE C UPDATED VERSION, NEWD, OF THE SCALE VECTOR D. FOR C IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED. C V(RDFCMN) (IN) MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT C VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1. C V(RDFCMX) (IN) MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0. C V(RELDX) (OUT) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED C BY FUNCTION RELDST AS C MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) / C MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P). C IF AN ACCEPTABLE STEP IS RETURNED, THEN V(RELDX) IS COM- C PUTED USING THE OUTPUT (POSSIBLY RESTORED) VALUES OF X C AND STEP. OTHERWISE IT IS COMPUTED USING THE INPUT C VALUES. C V(RFCTOL) (IN) RELATIVE FUNCTION CONVERGENCE TOLERANCE. IF THE C ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE- C DICTED AND V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)), THEN C ASSESS RETURNS WITH IV(IRC) = 8 OR 9. SEE ALSO V(LMAX0). C V(STPPAR) (IN) MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP. C V(TUNER1) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS MUCH LESS THAN EXPECTED. SUGGESTED C VALUE = 0.1. C V(TUNER2) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP. SUGGESTED C VALUE = 10**-4. C V(TUNER3) (IN) TUNING CONSTANT USED TO DECIDE IF THE RADIUS C SHOULD BE INCREASED. SUGGESTED VALUE = 0.75. C V(XCTOL) (IN) X-CONVERGENCE CRITERION. IF STEP IS A NEWTON STEP C (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING C AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN C ASSESS RETURNS IV(IRC) = 7 OR 9. C V(XFTOL) (IN) FALSE CONVERGENCE TOLERANCE. IF STEP GAVE NO OR ONLY C A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL), C THEN ASSESS RETURNS WITH IV(IRC) = 12. C C------------------------------- NOTES ------------------------------- C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR C LEAST-SQUARES) PACKAGE. IT MAY BE USED IN ANY UNCONSTRAINED C MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER, C OR LEVENBERG-MARQUARDT STEPS. C C *** ALGORITHM NOTES *** C C SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL C SWITCHING STRATEGIES. WHILE NL2SOL CONSIDERS ONLY TWO MODELS, C ASSESS IS DESIGNED TO HANDLE ANY NUMBER OF MODELS. C C *** USAGE NOTES *** C C ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES C STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND C V(PREDUC) NEED HAVE BEEN INITIALIZED. BETWEEN CALLS, NO I/O C VALUES EXECPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER- C ANCES SHOULD BE CHANGED. C AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN C CHANGE THE STOPPING TOLERANCES AND CALL ASSESS AGAIN, IN WHICH C CASE THE STOPPING TESTS WILL BE REPEATED. C C *** REFERENCES *** C C (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1981), C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, C ACM TRANS. MATH. SOFTWARE, VOL. 7, NO. 3. C C (2) POWELL, M.J.D. (1970) A FORTRAN SUBROUTINE FOR SOLVING C SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL C METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY C P. RABINOWITZ, GORDON AND BREACH, LONDON. C C *** HISTORY *** C C JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH C IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY. C DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE C PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS C PRESENT FORM (FALL 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL RELDST, VCOPY REAL RELDST C C VCOPY.... COPIES ONE VECTOR TO ANOTHER. C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS REAL ABS, AMAX1 C/ C *** NO COMMON BLOCKS *** C C-------------------------- LOCAL VARIABLES -------------------------- C LOGICAL GOODX INTEGER I, NFC REAL EMAX, GTS, HALF, ONE, RELDX1, RFAC1, TWO, XMAX, 1 ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0, 1 GTSLST, GTSTEP, INCFAC, IRC, LMAX0, MLSTGD, MODEL, NFCALL, 2 NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN, 3 RDFCMX, RELDX, RESTOR, RFCTOL, STAGE, STGLIM, STPPAR, 4 SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL, XFTOL, 5 XIRC C C *** DATA INITIALIZATIONS *** C C/6 DATA HALF/0.5E+0/, ONE/1.E+0/, TWO/2.E+0/, ZERO/0.E+0/ C/7 C PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0) C/ C C/6 DATA IRC/3/, MLSTGD/4/, MODEL/5/, NFCALL/6/, 1 NFGCAL/7/, RADINC/8/, RESTOR/9/, STAGE/10/, 2 STGLIM/11/, SWITCH/12/, TOOBIG/2/, XIRC/13/ C/7 C PARAMETER (IRC=3, MLSTGD=4, MODEL=5, NFCALL=6, C 1 NFGCAL=7, RADINC=8, RESTOR=9, STAGE=10, C 2 STGLIM=11, SWITCH=12, TOOBIG=2, XIRC=13) C/ C/6 DATA AFCTOL/31/, DECFAC/22/, DSTNRM/2/, DST0/3/, 1 DSTSAV/18/, F/10/, FDIF/11/, FLSTGD/12/, F0/13/, 2 GTSLST/14/, GTSTEP/4/, INCFAC/23/, 3 LMAX0/35/, NREDUC/6/, PLSTGD/15/, PREDUC/7/, 4 RADFAC/16/, RDFCMN/24/, RDFCMX/25/, 5 RELDX/17/, RFCTOL/32/, STPPAR/5/, TUNER1/26/, 6 TUNER2/27/, TUNER3/28/, XCTOL/33/, XFTOL/34/ C/7 C PARAMETER (AFCTOL=31, DECFAC=22, DSTNRM=2, DST0=3, C 1 DSTSAV=18, F=10, FDIF=11, FLSTGD=12, F0=13, C 2 GTSLST=14, GTSTEP=4, INCFAC=23, C 3 LMAX0=35, NREDUC=6, PLSTGD=15, PREDUC=7, C 4 RADFAC=16, RDFCMN=24, RDFCMX=25, C 5 RELDX=17, RFCTOL=32, STPPAR=5, TUNER1=26, C 6 TUNER2=27, TUNER3=28, XCTOL=33, XFTOL=34) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NFC = IV(NFCALL) IV(SWITCH) = 0 IV(RESTOR) = 0 RFAC1 = ONE GOODX = .TRUE. I = IV(IRC) IF (I .GE. 1 .AND. I .LE. 12) 1 GO TO (20,30,10,10,40,360,290,290,290,290,290,140), I IV(IRC) = 13 GO TO 999 C C *** INITIALIZE FOR NEW ITERATION *** C 10 IV(STAGE) = 1 IV(RADINC) = 0 V(FLSTGD) = V(F0) IF (IV(TOOBIG) .EQ. 0) GO TO 90 IV(STAGE) = -1 IV(XIRC) = I GO TO 60 C C *** STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS *** C *** FIRST DECIDE WHICH *** C 20 IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30 C *** OLD MODEL RETAINED, SMALLER RADIUS TRIED *** C *** DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION *** IV(STAGE) = IV(STGLIM) IV(RADINC) = -1 GO TO 90 C C *** A NEW MODEL IS BEING TRIED. DECIDE WHETHER TO KEEP IT. *** C 30 IV(STAGE) = IV(STAGE) + 1 C C *** NOW WE ADD THE POSSIBILTIY THAT STEP WAS RECOMPUTED WITH *** C *** THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP. *** C 40 IF (IV(STAGE) .GT. 0) GO TO 50 C C *** STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG. *** C IF (IV(TOOBIG) .NE. 0) GO TO 60 C C *** RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF. *** C IV(STAGE) = -IV(STAGE) I = IV(XIRC) GO TO (20, 30, 90, 90, 70), I C 50 IF (IV(TOOBIG) .EQ. 0) GO TO 70 C C *** HANDLE OVERSIZE STEP *** C IF (IV(RADINC) .GT. 0) GO TO 80 IV(STAGE) = -IV(STAGE) IV(XIRC) = IV(IRC) C 60 V(RADFAC) = V(DECFAC) IV(RADINC) = IV(RADINC) - 1 IV(IRC) = 5 GO TO 999 C 70 IF (V(F) .LT. V(FLSTGD)) GO TO 90 C C *** THE NEW STEP IS A LOSER. RESTORE OLD MODEL. *** C IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80 IV(MODEL) = IV(MLSTGD) IV(SWITCH) = 1 C C *** RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F). C 80 IF (V(FLSTGD) .GE. V(F0)) GO TO 90 IV(RESTOR) = 1 V(F) = V(FLSTGD) V(PREDUC) = V(PLSTGD) V(GTSTEP) = V(GTSLST) IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV) V(DSTNRM) = V(DSTSAV) NFC = IV(NFGCAL) GOODX = .FALSE. C C C *** COMPUTE RELATIVE CHANGE IN X BY CURRENT STEP *** C 90 RELDX1 = RELDST(P, D, X, X0) C C *** RESTORE X AND STEP IF NECESSARY *** C IF (GOODX) GO TO 105 DO 100 I = 1, P STEP(I) = STLSTG(I) X(I) = X0(I) + STLSTG(I) 100 CONTINUE C 105 V(FDIF) = V(F0) - V(F) IF (V(FDIF) .GT. V(TUNER2) * V(PREDUC)) GO TO 120 C C *** NO (OR ONLY A TRIVIAL) FUNCTION DECREASE C *** -- SO TRY NEW MODEL OR SMALLER RADIUS C V(RELDX) = RELDX1 IF (V(F) .LT. V(F0)) GO TO 110 IV(MLSTGD) = IV(MODEL) V(FLSTGD) = V(F) V(F) = V(F0) CALL VCOPY(P, X, X0) IV(RESTOR) = 1 GO TO 115 110 IV(NFGCAL) = NFC 115 IV(IRC) = 1 IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 130 IV(IRC) = 5 IV(RADINC) = IV(RADINC) - 1 GO TO 130 C C *** NONTRIVIAL FUNCTION DECREASE ACHIEVED *** C 120 IV(NFGCAL) = NFC RFAC1 = ONE IF (GOODX) V(RELDX) = RELDX1 V(DSTSAV) = V(DSTNRM) IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 200 C C *** DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS C *** OR ACCEPT STEP WITH DECREASED RADIUS. C IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 125 C *** CONSIDER SWITCHING MODELS *** IV(IRC) = 2 GO TO 130 C C *** ACCEPT STEP WITH DECREASED RADIUS *** C 125 IV(IRC) = 4 C C *** SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR *** C 130 IV(XIRC) = IV(IRC) EMAX = V(GTSTEP) + V(FDIF) V(RADFAC) = HALF * RFAC1 IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * AMAX1(V(RDFCMN), 1 HALF * V(GTSTEP)/EMAX) C C *** DO FALSE CONVERGENCE TEST *** C 140 IF (V(RELDX) .LE. V(XFTOL)) GO TO 160 IV(IRC) = IV(XIRC) IF (V(F) .LT. V(F0)) GO TO 230 GO TO 300 C 160 IV(IRC) = 12 GO TO 310 C C *** HANDLE GOOD FUNCTION DECREASE *** C 200 IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 260 C C *** INCREASING RADIUS LOOKS WORTHWHILE. SEE IF WE JUST C *** RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP C *** AFTER RECOMPUTING IT WITH A LARGER RADIUS. C IF (IV(RADINC) .LT. 0) GO TO 260 IF (IV(RESTOR) .EQ. 1) GO TO 260 C C *** WE DID NOT. TRY A LONGER STEP UNLESS THIS WAS A NEWTON C *** STEP. C V(RADFAC) = V(RDFCMX) GTS = V(GTSTEP) IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS) 1 V(RADFAC) = AMAX1(V(INCFAC), HALF*GTS/(GTS + V(FDIF))) IV(IRC) = 4 IF (V(STPPAR) .EQ. ZERO) GO TO 300 C *** STEP WAS NOT A NEWTON STEP. RECOMPUTE IT WITH C *** A LARGER RADIUS. IV(IRC) = 5 IV(RADINC) = IV(RADINC) + 1 C C *** SAVE VALUES CORRESPONDING TO GOOD STEP *** C 230 V(FLSTGD) = V(F) IV(MLSTGD) = IV(MODEL) CALL VCOPY(P, STLSTG, STEP) V(DSTSAV) = V(DSTNRM) IV(NFGCAL) = NFC V(PLSTGD) = V(PREDUC) V(GTSLST) = V(GTSTEP) GO TO 300 C C *** ACCEPT STEP WITH RADIUS UNCHANGED *** C 260 V(RADFAC) = ONE IV(IRC) = 3 GO TO 300 C C *** COME HERE FOR A RESTART AFTER CONVERGENCE *** C 290 IV(IRC) = IV(XIRC) IF (V(DSTSAV) .GE. ZERO) GO TO 310 IV(IRC) = 12 GO TO 310 C C *** PERFORM CONVERGENCE TESTS *** C 300 IV(XIRC) = IV(IRC) 310 IF (ABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10 IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999 EMAX = V(RFCTOL) * ABS(V(F0)) IF (V(DSTNRM) .GT. V(LMAX0) .AND. V(PREDUC) .LE. EMAX) 1 IV(IRC) = 11 IF (V(DST0) .LT. ZERO) GO TO 320 I = 0 IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR. 1 (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO)) I = 2 IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL) 1 .AND. GOODX) I = I + 1 IF (I .GT. 0) IV(IRC) = I + 6 C C *** CONSIDER RECOMPUTING STEP OF LENGTH V(LMAX0) FOR SINGULAR C *** CONVERGENCE TEST. C 320 IF (IABS(IV(IRC)-3) .GT. 2 .AND. IV(IRC) .NE. 12) GO TO 999 IF (V(DSTNRM) .GT. V(LMAX0)) GO TO 330 IF (V(PREDUC) .GE. EMAX) GO TO 999 IF (V(DST0) .LE. ZERO) GO TO 340 IF (HALF * V(DST0) .LE. V(LMAX0)) GO TO 999 GO TO 340 330 IF (HALF * V(DSTNRM) .LE. V(LMAX0)) GO TO 999 XMAX = V(LMAX0) / V(DSTNRM) IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAX) GO TO 999 340 IF (V(NREDUC) .LT. ZERO) GO TO 370 C C *** RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST *** C V(GTSLST) = V(GTSTEP) V(DSTSAV) = V(DSTNRM) IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV) V(PLSTGD) = V(PREDUC) IV(IRC) = 6 CALL VCOPY(P, STLSTG, STEP) GO TO 999 C C *** PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC) *** C 360 V(GTSTEP) = V(GTSLST) V(DSTNRM) = ABS(V(DSTSAV)) CALL VCOPY(P, STEP, STLSTG) IV(IRC) = IV(XIRC) IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12 V(NREDUC) = -V(PREDUC) V(PREDUC) = V(PLSTGD) 370 IF (-V(NREDUC) .LE. V(RFCTOL) * ABS(V(F0))) IV(IRC) = 11 C 999 RETURN C C *** LAST CARD OF ASSESS FOLLOWS *** END SUBROUTINE COVCLC(COVIRC, D, IV, J, N, NN, P, R, V, X) COV00010 C C *** COMPUTE COVARIANCE MATRIX FOR NL2ITR (NL2SOL VERSION 2.2) *** C C *** LET K = IABS(IV(COVREQ). FOR K .LE. 2, A FINITE-DIFFERENCE C *** HESSIAN H IS COMPUTED (USING FUNC. AND GRAD. VALUES IF C *** IV(COVREQ) IS NONNEGATIVE, AND USING ONLY FUNC. VALUES IF C *** IV(COVREQ) IS NEGATIVE). FOR SCALE = 2*F(X) / MAX(1, N-P), C *** WHERE 2*F(X) IS THE RESIDUAL SUM OF SQUARES, COVCLC COMPUTES... C *** K = 0 OR 1... SCALE * H**-1 * (J**T * J) * H**-1. C *** K = 2... SCALE * H**-1. C *** K .GE. 3... SCALE * (J**T * J)**-1. C C *** PARAMETER DECLARATIONS *** C INTEGER COVIRC, IV(1), N, NN, P REAL D(P), J(NN,P), R(N), V(1), X(P) C DIMENSION IV(*), V(*) C C *** LOCAL VARIABLES *** C LOGICAL HAVEJ INTEGER COV, GP, GSAVE1, G1, HC, HMI, HPI, HPM, I, IPIVI, IPIVK, 1 IP1, IRC, K, KIND, KL, L, M, MM1, MM1O2, PP1O2, QTR1, 2 RD1, STPI, STPM, STP0, WL, W0, W1 REAL DEL, HALF, NEGPT5, ONE, T, TWO, WK, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS, MAX0 REAL ABS, AMAX1, FLOAT, SQRT C/ C *** EXTERNAL SUBROUTINES *** C EXTERNAL LINVRT, LITVMU, LIVMUL, LSQRT, LTSQAR, QRFACT, 1 VCOPY, VSCOPY C C LINVRT... INVERT LOWER TRIANGULAR MATRIX. C LITVMU... APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C LIVMUL... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C LSQRT.... COMPUTE CHOLESKY FACTOR OF (LOWER TRINAG. OF) A SYM. MATRIX. C LTSQAR... GIVEN LOWER TRIANG. MATRIX L, COMPUTE (L**T)*L. C QRFACT... COMPUTE QR DECOMPOSITION OF A MATRIX. C VCOPY.... COPY ONE VECTOR TO ANOTHER. C VSCOPY... SET ALL ELEMENTS OF A VECTOR TO A SCALAR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVMAT, COVREQ, DELTA, DELTA0, DLTFDC, F, FX, G, H, IERR, 1 IPIVOT, IPIV0, KAGQT, KALM, LMAT, MODE, NFGCAL, QTR, 2 RD, RSAVE, SAVEI, SWITCH, TOOBIG, W, XMSAVE C C/6 DATA HALF/0.5E+0/, NEGPT5/-0.5E+0/, ONE/1.E+0/, TWO/2.E+0/, 1 ZERO/0.E+0/ C/7 C PARAMETER (HALF=0.5D+0, NEGPT5=-0.5D+0, ONE=1.D+0, TWO=2.D+0, C 1 ZERO=0.D+0) C/ C C/6 DATA COVMAT/26/, COVREQ/15/, DELTA/50/, DELTA0/44/, 1 DLTFDC/40/, F/10/, FX/46/, G/28/, H/44/, IERR/32/, 2 IPIVOT/61/, IPIV0/60/, KAGQT/35/, KALM/36/, 3 LMAT/58/, MODE/38/, NFGCAL/7/, QTR/49/, 4 RD/51/, RSAVE/52/, SAVEI/54/, SWITCH/12/, 5 TOOBIG/2/, W/59/, XMSAVE/49/ C/7 C PARAMETER (COVMAT=26, COVREQ=15, DELTA=50, DELTA0=44, C 1 DLTFDC=40, F=10, FX=46, G=28, H=44, IERR=32, C 2 IPIVOT=61, IPIV0=60, KAGQT=35, KALM=36, C 3 LMAT=58, MODE=38, NFGCAL=7, QTR=49, C 4 RD=51, RSAVE=52, SAVEI=54, SWITCH=12, C 5 TOOBIG=2, W=59, XMSAVE=49) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C COVIRC = 4 KIND = IV(COVREQ) M = IV(MODE) IF (M .GT. 0) GO TO 10 IV(KAGQT) = -1 IF (IV(KALM) .GT. 0) IV(KALM) = 0 IF (IABS(KIND) .GE. 3) GO TO 300 V(FX) = V(F) K = IV(RSAVE) CALL VCOPY(N, V(K), R) 10 IF (M .GT. P) GO TO 200 IF (KIND .LT. 0) GO TO 100 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND C *** GRADIENT VALUES. C GSAVE1 = IV(W) + P G1 = IV(G) IF (M .GT. 0) GO TO 15 C *** FIRST CALL ON COVCLC. SET GSAVE = G, TAKE FIRST STEP *** CALL VCOPY(P, V(GSAVE1), V(G1)) IV(SWITCH) = IV(NFGCAL) GO TO 80 C 15 DEL = V(DELTA) X(M) = V(XMSAVE) IF (IV(TOOBIG) .EQ. 0) GO TO 30 C C *** HANDLE OVERSIZE V(DELTA) *** C IF (DEL*X(M) .GT. ZERO) GO TO 20 C *** WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT *** IV(COVMAT) = -2 GO TO 190 C C *** TRY SHRINKING V(DELTA) *** 20 DEL = NEGPT5 * DEL GO TO 90 C 30 COV = IV(LMAT) GP = G1 + P - 1 C C *** SET G = (G - GSAVE)/DEL *** C DO 40 I = G1, GP V(I) = (V(I) - V(GSAVE1)) / DEL GSAVE1 = GSAVE1 + 1 40 CONTINUE C C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX *** C K = COV + M*(M-1)/2 L = K + M - 2 IF ( M .EQ. 1) GO TO 60 C C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 *** C DO 50 I = K, L V(I) = HALF * (V(I) + V(G1)) G1 = G1 + 1 50 CONTINUE C C *** ADD H(I,M) = G(I) FOR I = M TO P *** C 60 L = L + 1 DO 70 I = M, P V(L) = V(G1) L = L + I G1 = G1 + 1 70 CONTINUE C 80 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 190 C C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE *** C DEL = V(DELTA0) * AMAX1(ONE/D(M), ABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) 90 X(M) = X(M) + DEL V(DELTA) = DEL COVIRC = 2 GO TO 999 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY. C 100 STP0 = IV(W) + P - 1 MM1 = M - 1 MM1O2 = M*MM1/2 IF (M .GT. 0) GO TO 105 C *** FIRST CALL ON COVCLC. *** IV(SAVEI) = 0 GO TO 180 C 105 I = IV(SAVEI) IF (I .GT. 0) GO TO 160 IF (IV(TOOBIG) .EQ. 0) GO TO 120 C C *** HANDLE OVERSIZE STEP *** C STPM = STP0 + M DEL = V(STPM) IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 110 C *** WE ALREADY TRIED SHRINKING THE STEP, SO QUIT *** IV(COVMAT) = -2 GO TO 999 C C *** TRY SHRINKING THE STEP *** 110 DEL = NEGPT5 * DEL X(M) = X(XMSAVE) + DEL V(STPM) = DEL COVIRC = 1 GO TO 999 C C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) *** C 120 PP1O2 = P * (P-1) / 2 COV = IV(LMAT) HPM = COV + PP1O2 + MM1 V(HPM) = V(F) C C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. *** C HMI = COV + MM1O2 IF (MM1 .EQ. 0) GO TO 140 HPI = COV + PP1O2 DO 130 I = 1, MM1 V(HMI) = V(FX) - (V(F) + V(HPI)) HMI = HMI + 1 HPI = HPI + 1 130 CONTINUE 140 V(HMI) = V(F) - TWO*V(FX) C C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. *** C I = 1 C 150 IV(SAVEI) = I STPI = STP0 + I V(DELTA) = X(I) X(I) = X(I) + V(STPI) IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI) COVIRC = 1 GO TO 999 C 160 X(I) = V(DELTA) IF (IV(TOOBIG) .EQ. 0) GO TO 170 C *** PUNT IN THE EVENT OF AN OVERSIZE STEP *** IV(COVMAT) = -2 GO TO 999 C C *** FINISH COMPUTING H(M,I) *** C 170 STPI = STP0 + I HMI = COV + MM1O2 + I - 1 STPM = STP0 + M V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM)) I = I + 1 IF (I .LE. M) GO TO 150 IV(SAVEI) = 0 X(M) = V(XMSAVE) C 180 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 190 C C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H. C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR. C DEL = V(DLTFDC) * AMAX1(ONE/D(M), ABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) X(M) = X(M) + DEL STPM = STP0 + M V(STPM) = DEL COVIRC = 1 GO TO 999 C C *** RESTORE R, V(F), ETC. *** C 190 K = IV(RSAVE) CALL VCOPY(N, R, V(K)) V(F) = V(FX) IF (KIND .LT. 0) GO TO 200 IV(NFGCAL) = IV(SWITCH) QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) IF (IV(COVMAT) .LT. 0) GO TO 999 COVIRC = 3 GO TO 999 C 200 COV = IV(LMAT) C C *** THE COMPLETE FINITE-DIFF. HESSIAN IS NOW STORED AT V(COV). *** C *** USE IT TO COMPUTE THE REQUESTED COVARIANCE MATRIX. *** C C *** COMPUTE CHOLESKY FACTOR C OF H = C*(C**T) *** C *** AND STORE IT AT V(HC). *** C HC = COV IF (IABS(KIND) .EQ. 2) GO TO 210 HC = IABS(IV(H)) IV(H) = -HC 210 CALL LSQRT(1, P, V(HC), V(COV), IRC) IV(COVMAT) = -1 IF (IRC .NE. 0) GO TO 999 C W1 = IV(W) + P IF (IABS(KIND) .GT. 1) GO TO 350 C C *** COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1 *** C CALL VSCOPY(P*(P+1)/2, V(COV), ZERO) HAVEJ = IV(KALM) .EQ. (-1) C *** HAVEJ = .TRUE. MEANS J IS IN ITS ORIGINAL FORM, WHILE C *** HAVEJ = .FALSE. MEANS QRFACT HAS BEEN APPLIED TO J. C M = P IF (HAVEJ) M = N W0 = W1 - 1 RD1 = IV(RD) DO 290 I = 1, M IF (HAVEJ) GO TO 240 C C *** SET W = IPIVOT * (ROW I OF R MATRIX FROM QRFACT). *** C CALL VSCOPY(P, V(W1), ZERO) IPIVI = IPIV0 + I L = W0 + IV(IPIVI) V(L) = V(RD1) RD1 = RD1 + 1 IF (I .EQ. P) GO TO 260 IP1 = I + 1 DO 230 K = IP1, P IPIVK = IPIV0 + K L = W0 + IV(IPIVK) V(L) = J(I,K) 230 CONTINUE GO TO 260 C C *** SET W = (ROW I OF J). *** C 240 L = W0 DO 250 K = 1, P L = L + 1 V(L) = J(I,K) 250 CONTINUE C C *** SET W = H**-1 * W. *** C 260 CALL LIVMUL(P, V(W1), V(HC), V(W1)) CALL LITVMU(P, V(W1), V(HC), V(W1)) C C *** ADD W * W**T TO COVARIANCE MATRIX. *** C KL = COV DO 280 K = 1, P L = W0 + K WK = V(L) DO 270 L = 1, K WL = W0 + L V(KL) = V(KL) + WK * V(WL) KL = KL + 1 270 CONTINUE 280 CONTINUE 290 CONTINUE GO TO 380 C C *** COVARIANCE = SCALE * (J**T * J)**-1. *** C 300 RD1 = IV(RD) IF (IV(KALM) .NE. (-1)) GO TO 310 C C *** APPLY QRFACT TO J *** C QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) W1 = IV(W) + P CALL QRFACT(NN, N, P, J, V(RD1), IV(IPIVOT), IV(IERR), 0, 1 V(W1)) IV(KALM) = -2 310 IV(COVMAT) = -1 IF (IV(IERR) .NE. 0) GO TO 999 COV = IV(LMAT) HC = IABS(IV(H)) IV(H) = -HC C C *** SET HC = (R MATRIX FROM QRFACT). *** C L = HC DO 340 I = 1, P IF (I .GT. 1) CALL VCOPY(I-1, V(L), J(1,I)) L = L + I - 1 V(L) = V(RD1) L = L + 1 RD1 = RD1 + 1 340 CONTINUE C C *** THE CHOLESKY FACTOR C OF THE UNSCALED INVERSE COVARIANCE MATRIX C *** (OR PERMUTATION THEREOF) IS STORED AT V(HC). C C *** SET C = C**-1. C 350 CALL LINVRT(P, V(HC), V(HC)) C C *** SET C = C**T * C. C CALL LTSQAR(P, V(HC), V(HC)) C IF (HC .EQ. COV) GO TO 380 C C *** C = PERMUTED, UNSCALED COVARIANCE. C *** SET COV = IPIVOT * C * IPIVOT**T. C DO 370 I = 1, P M = IPIV0 + I IPIVI = IV(M) KL = COV-1 + IPIVI*(IPIVI-1)/2 DO 360 K = 1, I M = IPIV0 + K IPIVK = IV(M) L = KL + IPIVK IF (IPIVK .GT. IPIVI) 1 L = L + (IPIVK-IPIVI)*(IPIVK+IPIVI-3)/2 V(L) = V(HC) HC = HC + 1 360 CONTINUE 370 CONTINUE C 380 IV(COVMAT) = COV C C *** APPLY SCALE FACTOR = (RESID. SUM OF SQUARES) / MAX(1,N-P). C T = V(F) / (HALF * FLOAT(MAX0(1,N-P))) K = COV - 1 + P*(P+1)/2 DO 390 I = COV, K 390 V(I) = T * V(I) C 999 RETURN C *** LAST CARD OF COVCLC FOLLOWS *** END SUBROUTINE DFAULT(IV, V) DFA00010 C C *** SUPPLY NL2SOL (VERSION 2.2) DEFAULT VALUES TO IV AND V *** C INTEGER IV(25) REAL V(45) C/+ REAL AMAX1 C/ EXTERNAL IMDCON, RMDCON INTEGER IMDCON REAL RMDCON C REAL MACHEP, MEPCRT, ONE, SQTEPS, THREE C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AFCTOL, COSMIN, COVPRT, COVREQ, DECFAC, DELTA0, DFAC, 1 DINIT, DLTFDC, DLTFDJ, DTYPE, D0INIT, EPSLON, FUZZ, 2 INCFAC, INITS, JTINIT, LMAX0, MXFCAL, MXITER, OUTLEV, 3 PARPRT, PHMNFC, PHMXFC, PRUNIT, RDFCMN, RDFCMX, 4 RFCTOL, RLIMIT, SOLPRT, STATPR, TUNER1, TUNER2, TUNER3, 5 TUNER4, TUNER5, XCTOL, XFTOL, X0PRT C C/6 DATA ONE/1.E+0/, THREE/3.E+0/ C/7 C PARAMETER (ONE=1.D+0, THREE=3.D+0) C/ C C *** IV SUBSCRIPT VALUES *** C C/6 DATA COVPRT/14/, COVREQ/15/, DTYPE/16/, INITS/25/, 1 MXFCAL/17/, MXITER/18/, OUTLEV/19/, 2 PARPRT/20/, PRUNIT/21/, SOLPRT/22/, 3 STATPR/23/, X0PRT/24/ C/7 C PARAMETER (COVPRT=14, COVREQ=15, DTYPE=16, INITS=25, C 1 MXFCAL=17, MXITER=18, OUTLEV=19, C 2 PARPRT=20, PRUNIT=21, SOLPRT=22, C 3 STATPR=23, X0PRT=24) C/ C C *** V SUBSCRIPT VALUES *** C C/6 DATA AFCTOL/31/, COSMIN/43/, DECFAC/22/, 1 DELTA0/44/, DFAC/41/, DINIT/38/, DLTFDC/40/, 2 DLTFDJ/36/, D0INIT/37/, EPSLON/19/, FUZZ/45/, 3 INCFAC/23/, JTINIT/39/, LMAX0/35/, PHMNFC/20/, 4 PHMXFC/21/, RDFCMN/24/, RDFCMX/25/, 5 RFCTOL/32/, RLIMIT/42/, TUNER1/26/, 6 TUNER2/27/, TUNER3/28/, TUNER4/29/, 7 TUNER5/30/, XCTOL/33/, XFTOL/34/ C/7 C PARAMETER (AFCTOL=31, COSMIN=43, DECFAC=22, C 1 DELTA0=44, DFAC=41, DINIT=38, DLTFDC=40, C 2 DLTFDJ=36, D0INIT=37, EPSLON=19, FUZZ=45, C 3 INCFAC=23, JTINIT=39, LMAX0=35, PHMNFC=20, C 4 PHMXFC=21, RDFCMN=24, RDFCMX=25, C 5 RFCTOL=32, RLIMIT=42, TUNER1=26, C 6 TUNER2=27, TUNER3=28, TUNER4=29, C 7 TUNER5=30, XCTOL=33, XFTOL=34) C/ C C----------------------------------------------------------------------- C IV(1) = 12 IV(COVPRT) = 1 IV(COVREQ) = 1 IV(DTYPE) = 1 IV(INITS) = 0 IV(MXFCAL) = 200 IV(MXITER) = 150 IV(OUTLEV) = 1 IV(PARPRT) = 1 IV(PRUNIT) = IMDCON(1) IV(SOLPRT) = 1 IV(STATPR) = 1 IV(X0PRT) = 1 C MACHEP = RMDCON(3) V(AFCTOL) = 1.E-20 IF (MACHEP .GT. 1.E-10) V(AFCTOL) = MACHEP**2 V(COSMIN) = AMAX1(1.E-6, 1.E+2 * MACHEP) V(DECFAC) = 0.5E+0 SQTEPS = RMDCON(4) V(DELTA0) = SQTEPS V(DFAC) = 0.6E+0 V(DINIT) = 0.E+0 MEPCRT = MACHEP ** (ONE/THREE) V(DLTFDC) = MEPCRT V(DLTFDJ) = SQTEPS V(D0INIT) = 1.E+0 V(EPSLON) = 0.1E+0 V(FUZZ) = 1.5E+0 V(INCFAC) = 2.E+0 V(JTINIT) = 1.E-6 V(LMAX0) = 100.E+0 V(PHMNFC) = -0.1E+0 V(PHMXFC) = 0.1E+0 V(RDFCMN) = 0.1E+0 V(RDFCMX) = 4.E+0 V(RFCTOL) = AMAX1(1.E-10, MEPCRT**2) V(RLIMIT) = RMDCON(5) V(TUNER1) = 0.1E+0 V(TUNER2) = 1.E-4 V(TUNER3) = 0.75E+0 V(TUNER4) = 0.5E+0 V(TUNER5) = 0.75E+0 V(XCTOL) = SQTEPS V(XFTOL) = 1.E+2 * MACHEP C 999 RETURN C *** LAST CARD OF DFAULT FOLLOWS *** END REAL FUNCTION DOTPRD(P, X, Y) DOT00010 C C *** RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y. *** C INTEGER P REAL X(P), Y(P) C INTEGER I REAL ONE, SQTETA, T, ZERO C/+ REAL AMAX1, ABS C/ EXTERNAL RMDCON REAL RMDCON C C *** RMDCON(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH C *** IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT C *** CAN BE SQUARED WITHOUT UNDERFLOWING. C C/6 DATA ONE/1.E+0/, SQTETA/0.E+0/, ZERO/0.E+0/ C/7 C PARAMETER (ONE=1.D+0, ZERO=0.D+0) C DATA SQTETA/0.D+0/ C/ C DOTPRD = ZERO IF (P .LE. 0) GO TO 999 IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2) DO 20 I = 1, P T = AMAX1(ABS(X(I)), ABS(Y(I))) IF (T .GT. ONE) GO TO 10 IF (T .LT. SQTETA) GO TO 20 T = (X(I)/SQTETA)*Y(I) IF (ABS(T) .LT. SQTETA) GO TO 20 10 DOTPRD = DOTPRD + X(I)*Y(I) 20 CONTINUE C 999 RETURN C *** LAST CARD OF DOTPRD FOLLOWS *** END SUBROUTINE DUPDAT(D, IV, J, N, NN, P, V) DUP00010 C C *** UPDATE SCALE VECTOR D FOR NL2ITR (NL2SOL VERSION 2.2) *** C C *** PARAMETER DECLARATIONS *** C INTEGER IV(1), N, NN, P REAL D(P), J(NN,P), V(1) C DIMENSION IV(*), V(*) C C *** LOCAL VARIABLES *** C INTEGER D0, I, JTOLI, S1 REAL SII, T, VDFAC C C *** CONSTANTS *** REAL ZERO C C *** INTRINSIC FUNCTIONS *** C/+ REAL AMAX1, SQRT C/ C *** EXTERNAL FUNCTION *** C EXTERNAL V2NORM REAL V2NORM C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DFAC, DTYPE, JTOL0, NITER, S C/6 DATA DFAC/41/, DTYPE/16/, JTOL0/86/, NITER/31/, S/53/ C/7 C PARAMETER (DFAC=41, DTYPE=16, JTOL0=86, NITER=31, S=53) C/ C C/6 DATA ZERO/0.E+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C C----------------------------------------------------------------------- C I = IV(DTYPE) IF (I .EQ. 1) GO TO 20 IF (IV(NITER) .GT. 0) GO TO 999 C 20 VDFAC = V(DFAC) D0 = JTOL0 + P S1 = IV(S) - 1 DO 30 I = 1, P S1 = S1 + I SII = V(S1) T = V2NORM(N, J(1,I)) IF (SII .GT. ZERO) T = SQRT(T*T + SII) JTOLI = JTOL0 + I D0 = D0 + 1 IF (T .LT. V(JTOLI)) T = AMAX1(V(D0), V(JTOLI)) D(I) = AMAX1(VDFAC*D(I), T) 30 CONTINUE C 999 RETURN C *** LAST CARD OF DUPDAT FOLLOWS *** END SUBROUTINE GQTSTP(D, DIG, DIHDI, KA, L, P, STEP, V, W) GQT00010 C C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE *** C *** (NL2SOL VERSION 2.2) *** C C *** PARAMETER DECLARATIONS *** C INTEGER KA, P REAL D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P), 1 W(1) C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED C HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR, C THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF C APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE. IN C OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE C PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP SUCH THAT THE C 2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE C G IS THE GRADIENT, H IS THE HESSIAN, AND D IS A DIAGONAL C SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D. C (GQTSTP ASSUMES DIG = D**-1 * G AND DIHDI = D**-1 * H * D**-1.) C IF G = 0, HOWEVER, STEP = 0 IS RETURNED (EVEN AT A SADDLE POINT). C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE C MATRIX D MENTIONED ABOVE UNDER PURPOSE. C DIG (IN) = THE SCALED GRADIENT VECTOR, D**-1 * G. IF G = 0, THEN C STEP = 0 AND V(STPPAR) = 0 ARE RETURNED. C DIHDI (IN) = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION), C I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E., C IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC. C KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER- C MINE STEP. KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST C ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI) C -- KA IS INITIALIZED TO 0 IN THIS CASE. OUTPUT WITH C KA = 0 (OR V(STPPAR) = 0) MEANS STEP = -(H**-1)*G. C L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS. C P (IN) = NUMBER OF PARAMETERS -- THE HESSIAN IS A P X P MATRIX. C STEP (I/O) = THE STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH 4*P + 6. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR C OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED FOR PSI(STEP). FOR THE C STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE C BY LESS THAN -V(EPSLON)*PSI(STEP). SUGGESTED VALUE = 0.1. C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP) (FOR POS. DEF. C H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE). C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5. C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA C DESCRIBED BELOW UNDER ALGORITHM NOTES. IF H + ALPHA*D**2 C (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER, C THEN V(STPPAR) = -ALPHA. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY STEP AND W ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE WITH C KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO- C NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND C V(RAD0) OF V MUST BE INITIALIZED. TO COMPUTE STEP FROM A SADDLE C POINT (WHERE THE TRUE GRADIENT VANISHES AND H HAS A NEGATIVE C EIGENVALUE), A NONZERO G WITH SMALL COMPONENTS SHOULD BE PASSED. C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST- C SQUARES) PACKAGE (REF. 1), BUT IT COULD BE USED IN SOLVING ANY C UNCONSTRAINED MINIMIZATION PROBLEM. C C *** ALGORITHM NOTES *** C C THE DESIRED G-Q-T STEP (REF. 2, 3, 4) SATISFIES C (H + ALPHA*D**2)*STEP = -G FOR SOME NONNEGATIVE ALPHA SUCH THAT C H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE. ALPHA AND STEP ARE C COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5. C ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN C ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A C SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 6. CASES IN WHICH C H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY C THE TECHNIQUE DISCUSSED IN REF. 2. IN THESE CASES, A STEP OF C (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS C ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP). C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS. C LITVMU - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C LIVMUL - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX. C LSQRT - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.). C LSVMIN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX. C RMDCON - RETURNS MACHINE-DEPENDENT CONSTANTS. C V2NORM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP. C 186-197. C 3. GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966), C MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34, C PP. 541-551. C 4. HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT C SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS C DIV., A.E.R.E. HARWELL, OXON., ENGLAND. C 5. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C 6. VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15, C PP. 719-729. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C LOGICAL RESTRT INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC, 1 J, K, KALIM, K1, LK0, PHIPIN, Q, Q0, UK0, X, X0 REAL ALPHAK, AKI, AKK, DELTA, DST, EPSO6, LK, 1 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, 2 ROOT, SI, SK, SW, T, TWOPSI, T1, UK, WI C C *** CONSTANTS *** REAL DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE, ONE, 1 P001, SIX, THREE, TWO, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ REAL ABS, AMAX1, AMIN1, SQRT C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL DOTPRD, LITVMU, LIVMUL, LSQRT, LSVMIN, RMDCON, V2NORM REAL DOTPRD, LSVMIN, RMDCON, V2NORM C C *** SUBSCRIPTS FOR V *** C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC, 1 PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0 C/6 DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, 1 GTSTEP/4/, NREDUC/6/, PHMNFC/20/, 2 PHMXFC/21/, PREDUC/7/, RADIUS/8/, 3 RAD0/9/, STPPAR/5/ C/7 C PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, C 1 GTSTEP=4, NREDUC=6, PHMNFC=20, C 2 PHMXFC=21, PREDUC=7, RADIUS=8, C 3 RAD0=9, STPPAR=5) C/ C C/6 DATA EPSFAC/50.0E+0/, FOUR/4.0E+0/, HALF/0.5E+0/, 1 KAPPA/2.0E+0/, NEGONE/-1.0E+0/, ONE/1.0E+0/, P001/1.0E-3/, 2 SIX/6.0E+0/, THREE/3.0E+0/, TWO/2.0E+0/, ZERO/0.0E+0/ C/7 C PARAMETER (EPSFAC=50.0D+0, FOUR=4.0D+0, HALF=0.5D+0, C 1 KAPPA=2.0D+0, NEGONE=-1.0D+0, ONE=1.0D+0, P001=1.0D-3, C 2 SIX=6.0D+0, THREE=3.0D+0, TWO=2.0D+0, ZERO=0.0D+0) C SAVE DGXFAC C/ DATA DGXFAC/0.E+0/ C C *** BODY *** C C *** STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX). DGGDMX = P + 1 C *** STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST C *** AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX) C *** AND W(EMIN) RESPECTIVELY. EMAX = DGGDMX + 1 EMIN = EMAX + 1 C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST, C *** AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF. C *** H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN) C *** RESPECTIVELY. LK0 = EMIN + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 C *** STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P). DIAG0 = DSTSAV DIAG = DIAG0 + 1 C *** STORE -D*STEP IN W(Q),...,W(Q0+P). Q0 = DIAG0 + P Q = Q0 + 1 RAD = V(RADIUS) C *** PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF C *** D*STEP. PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD C *** EPSO6 AND PSIFAC ARE USED IN CHECKING FOR THE SPECIAL CASE C *** OF (NEARLY) SINGULAR H + ALPHA*D**2 (SEE REF. 2). PSIFAC = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) * 1 (KAPPA + ONE) + KAPPA + TWO) * RAD**2) C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO EPSO6 = V(EPSLON)/SIX IRC = 0 RESTRT = .FALSE. KALIM = KA + 50 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA .GE. 0) GO TO 310 C C *** FRESH START *** C K = 0 UK = NEGONE KA = 0 KALIM = 50 C C *** STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P) *** C J = 0 DO 20 I = 1, P J = J + I K1 = DIAG0 + I W(K1) = DIHDI(J) 20 CONTINUE C C *** DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI *** C T1 = ZERO J = P * (P + 1) / 2 DO 30 I = 1, J T = ABS(DIHDI(I)) IF (T1 .LT. T) T1 = T 30 CONTINUE W(DGGDMX) = T1 C C *** TRY ALPHA = 0 *** C 40 CALL LSQRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 60 C *** INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, USE THIS C *** ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA. J = IRC*(IRC+1)/2 T = L(J) L(J) = ONE DO 50 I = 1, IRC 50 W(I) = ZERO W(IRC) = ONE CALL LITVMU(IRC, W, L, W) T1 = V2NORM(IRC, W) LK = -T / T1 / T1 V(DST0) = -LK IF (RESTRT) GO TO 210 V(NREDUC) = ZERO GO TO 70 C C *** POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP. *** 60 LK = ZERO CALL LIVMUL(P, W(Q), L, DIG) V(NREDUC) = HALF * DOTPRD(P, W(Q), W(Q)) CALL LITVMU(P, W(Q), L, W(Q)) DST = V2NORM(P, W(Q)) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 280 IF (RESTRT) GO TO 210 C C *** PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND C *** SMALLEST) EIGENVALUES. *** C 70 V(DGNORM) = V2NORM(P, DIG) IF (V(DGNORM) .EQ. ZERO) GO TO 450 K = 0 DO 100 I = 1, P WI = ZERO IF (I .EQ. 1) GO TO 90 IM1 = I - 1 DO 80 J = 1, IM1 K = K + 1 T = ABS(DIHDI(K)) WI = WI + T W(J) = W(J) + T 80 CONTINUE 90 W(I) = WI K = K + 1 100 CONTINUE C C *** (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1) *** C K = 1 T1 = W(DIAG) - W(1) IF (P .LE. 1) GO TO 120 DO 110 I = 2, P J = DIAG0 + I T = W(J) - W(I) IF (T .GE. T1) GO TO 110 T1 = T K = I 110 CONTINUE C 120 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 150 I = 1, P IF (I .EQ. K) GO TO 130 AKI = ABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (AKK - W(J) + SI - AKI) T1 = T1 + SQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 140 130 INC = I 140 K1 = K1 + INC 150 CONTINUE C W(EMIN) = AKK - T UK = V(DGNORM)/RAD - W(EMIN) C C *** COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE *** C K = 1 T1 = W(DIAG) + W(1) IF (P .LE. 1) GO TO 170 DO 160 I = 2, P J = DIAG0 + I T = W(J) + W(I) IF (T .LE. T1) GO TO 160 T1 = T K = I 160 CONTINUE C 170 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 200 I = 1, P IF (I .EQ. K) GO TO 180 AKI = ABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (W(J) + SI - AKI - AKK) T1 = T1 + SQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 190 180 INC = I 190 K1 = K1 + INC 200 CONTINUE C W(EMAX) = AKK + T LK = AMAX1(LK, V(DGNORM)/RAD - W(EMAX)) C C *** ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE). WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD C IF (IRC .NE. 0) GO TO 210 C C *** COMPUTE L0 FOR POSITIVE DEFINITE H *** C CALL LIVMUL(P, W, L, W(Q)) T = V2NORM(P, W) W(PHIPIN) = DST / T / T LK = AMAX1(LK, PHI*W(PHIPIN)) C C *** SAFEGUARD ALPHAK AND ADD ALPHAK*I TO (D**-1)*H*(D**-1) *** C 210 KA = KA + 1 IF (-V(DST0) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK) 1 ALPHAK = UK * AMAX1(P001, SQRT(LK/UK)) K = 0 DO 220 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) + ALPHAK 220 CONTINUE C C *** TRY COMPUTING CHOLESKY DECOMPOSITION *** C CALL LSQRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 250 C C *** (D**-1)*H*(D**-1) + ALPHAK*I IS INDEFINITE -- OVERESTIMATE C *** SMALLEST EIGENVALUE FOR USE IN UPDATING LK *** C J = (IRC*(IRC+1))/2 T = L(J) L(J) = ONE DO 230 I = 1, IRC 230 W(I) = ZERO W(IRC) = ONE CALL LITVMU(IRC, W, L, W) T1 = V2NORM(IRC, W) LK = ALPHAK - T/T1/T1 V(DST0) = -LK GO TO 210 C C *** ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE. C *** COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE. *** C 250 CALL LIVMUL(P, W(Q), L, DIG) CALL LITVMU(P, W(Q), L, W(Q)) DST = V2NORM(P, W(Q)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 290 IF (PHI .EQ. OLDPHI) GO TO 290 OLDPHI = PHI IF (PHI .GT. ZERO) GO TO 260 C *** CHECK FOR THE SPECIAL CASE OF H + ALPHA*D**2 (NEARLY) C *** SINGULAR. DELTA IS .GE. THE SMALLEST EIGENVALUE OF C *** (D**-1)*H*(D**-1) + ALPHAK*I. IF (V(DST0) .GT. ZERO) GO TO 260 DELTA = ALPHAK + V(DST0) TWOPSI = ALPHAK*DST*DST + DOTPRD(P, DIG, W(Q)) IF (DELTA .LT. PSIFAC*TWOPSI) GO TO 270 C C *** UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK *** C 260 IF (KA .GE. KALIM) GO TO 290 CALL LIVMUL(P, W, L, W(Q)) T1 = V2NORM(P, W) C *** THE FOLLOWING DMIN1 IS NECESSARY BECAUSE OF RESTARTS *** IF (PHI .LT. ZERO) UK = AMIN1(UK, ALPHAK) ALPHAK = ALPHAK + (PHI/T1) * (DST/T1) * (DST/RAD) LK = AMAX1(LK, ALPHAK) GO TO 210 C C *** DECIDE HOW TO HANDLE (NEARLY) SINGULAR H + ALPHA*D**2 *** C C *** IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC. 270 IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * RMDCON(3) C C *** NOW DECIDE. *** IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 350 C *** DELTA IS SO SMALL WE CANNOT HANDLE THE SPECIAL CASE IN C *** THE AVAILABLE ARITHMETIC. ACCEPT STEP AS IT IS. GO TO 290 C C *** ACCEPTABLE STEP ON FIRST TRY *** C 280 ALPHAK = ZERO C C *** SUCCESSFUL STEP IN GENERAL. COMPUTE STEP = -(D**-1)*Q *** C 290 DO 300 I = 1, P J = Q0 + I STEP(I) = -W(J)/D(I) 300 CONTINUE V(GTSTEP) = -DOTPRD(P, DIG, W(Q)) V(PREDUC) = HALF * (ABS(ALPHAK)*DST*DST - V(GTSTEP)) GO TO 430 C C C *** RESTART WITH NEW RADIUS *** C 310 IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 330 C C *** PREPARE TO RETURN NEWTON STEP *** C RESTRT = .TRUE. KA = KA + 1 K = 0 DO 320 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) 320 CONTINUE UK = NEGONE GO TO 40 C 330 IF (KA .EQ. 0) GO TO 60 C DST = W(DSTSAV) ALPHAK = ABS(V(STPPAR)) PHI = DST - RAD T = V(DGNORM)/RAD IF (RAD .GT. V(RAD0)) GO TO 340 C C *** SMALLER RADIUS *** UK = T - W(EMIN) LK = ZERO IF (ALPHAK .GT. ZERO) LK = W(LK0) LK = AMAX1(LK, T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 260 C C *** BIGGER RADIUS *** 340 UK = T - W(EMIN) IF (ALPHAK .GT. ZERO) UK = AMIN1(UK, W(UK0)) LK = AMAX1(ZERO, -V(DST0), T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 260 C C *** HANDLE (NEARLY) SINGULAR H + ALPHA*D**2 *** C C *** NEGATE ALPHAK TO INDICATE SPECIAL CASE *** 350 ALPHAK = -ALPHAK C *** ALLOCATE STORAGE FOR SCRATCH VECTOR X *** X0 = Q0 + P X = X0 + 1 C C *** USE INVERSE POWER METHOD WITH START FROM LSVMIN TO OBTAIN C *** APPROXIMATE EIGENVECTOR CORRESPONDING TO SMALLEST EIGENVALUE C *** OF (D**-1)*H*(D**-1). C DELTA = KAPPA*DELTA T = LSVMIN(P, L, W(X), W) C K = 0 C *** NORMALIZE W *** 360 DO 370 I = 1, P 370 W(I) = T*W(I) C *** COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W. CALL LITVMU(P, W, L, W) T1 = ONE/V2NORM(P, W) T = T1*T IF (T .LE. DELTA) GO TO 390 IF (K .GT. 30) GO TO 290 K = K + 1 C *** START NEXT INV. POWER ITER. BY STORING NORMALIZED W IN X. DO 380 I = 1, P J = X0 + I W(J) = T1*W(I) 380 CONTINUE C *** COMPUTE W = (L**-1)*X. CALL LIVMUL(P, W, L, W(X)) T = ONE/V2NORM(P, W) GO TO 360 C 390 DO 400 I = 1, P 400 W(I) = T1*W(I) C C *** NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND C *** T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W. C SW = DOTPRD(P, W(Q), W) T1 = (RAD + DST) * (RAD - DST) ROOT = SQRT(SW*SW + T1) IF (SW .LT. ZERO) ROOT = -ROOT SI = T1 / (SW + ROOT) C *** ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A C *** FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3. V(PREDUC) = HALF*TWOPSI T1 = ZERO T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T*DOTPRD(P,W(X),W))) IF (T .LT. EPSO6*TWOPSI) GO TO 410 V(PREDUC) = V(PREDUC) + T DST = RAD T1 = -SI 410 DO 420 I = 1, P J = Q0 + I W(J) = T1*W(I) - W(J) STEP(I) = W(J) / D(I) 420 CONTINUE V(GTSTEP) = DOTPRD(P, DIG, W(Q)) C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 430 V(DSTNRM) = DST V(STPPAR) = ALPHAK W(LK0) = LK W(UK0) = UK V(RAD0) = RAD W(DSTSAV) = DST C C *** RESTORE DIAGONAL OF DIHDI *** C J = 0 DO 440 I = 1, P J = J + I K = DIAG0 + I DIHDI(J) = W(K) 440 CONTINUE GO TO 999 C C *** SPECIAL CASE -- G = 0 *** C 450 V(STPPAR) = ZERO V(PREDUC) = ZERO V(DSTNRM) = ZERO V(GTSTEP) = ZERO DO 460 I = 1, P 460 STEP(I) = ZERO C 999 RETURN C C *** LAST CARD OF GQTSTP FOLLOWS *** END SUBROUTINE ITSMRY(D, IV, P, V, X) ITS00010 C C *** PRINT NL2SOL (VERSION 2.2) ITERATION SUMMARY *** C C *** PARAMETER DECLARATIONS *** C INTEGER IV(1), P REAL D(P), V(1), X(P) C DIMENSION IV(*), V(*) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER COV1, G1, I, II, IV1, I1, J, M, NF, NG, OL, PU C/6 REAL MODEL1(6), MODEL2(6) C/7 C CHARACTER*4 MODEL1(6), MODEL2(6) C/ REAL NRELDF, OLDF, PRELDF, RELDF, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS C/ C *** NO EXTERNAL FUNCTIONS OR SUBROUTINES *** C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVMAT, COVPRT, COVREQ, DSTNRM, F, FDIF, F0, G, 1 NEEDHD, NFCALL, NFCOV, NGCOV, NGCALL, NITER, NREDUC, 2 OUTLEV, PREDUC, PRNTIT, PRUNIT, RELDX, SIZE, SOLPRT, 3 STATPR, STPPAR, SUSED, X0PRT C C *** IV SUBSCRIPT VALUES *** C C/6 DATA COVMAT/26/, COVPRT/14/, G/28/, COVREQ/15/, 1 NEEDHD/39/, NFCALL/6/, NFCOV/40/, NGCOV/41/, 2 NGCALL/30/, NITER/31/, OUTLEV/19/, PRNTIT/48/, 3 PRUNIT/21/, SOLPRT/22/, STATPR/23/, SUSED/57/, 4 X0PRT/24/ C/7 C PARAMETER (COVMAT=26, COVPRT=14, G=28, COVREQ=15, C 1 NEEDHD=39, NFCALL=6, NFCOV=40, NGCOV=41, C 2 NGCALL=30, NITER=31, OUTLEV=19, PRNTIT=48, C 3 PRUNIT=21, SOLPRT=22, STATPR=23, SUSED=57, C 4 X0PRT=24) C/ C C *** V SUBSCRIPT VALUES *** C C/6 DATA DSTNRM/2/, F/10/, F0/13/, FDIF/11/, NREDUC/6/, 1 PREDUC/7/, RELDX/17/, SIZE/47/, STPPAR/5/ C/7 C PARAMETER (DSTNRM=2, F=10, F0=13, FDIF=11, NREDUC=6, C 1 PREDUC=7, RELDX=17, SIZE=47, STPPAR=5) C/ C C/6 DATA ZERO/0.E+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C/6 DATA MODEL1(1)/4H /, MODEL1(2)/4H /, MODEL1(3)/4H /, 1 MODEL1(4)/4H /, MODEL1(5)/4H G /, MODEL1(6)/4H S /, 2 MODEL2(1)/4H G /, MODEL2(2)/4H S /, MODEL2(3)/4HG-S /, 3 MODEL2(4)/4HS-G /, MODEL2(5)/4H-S-G/, MODEL2(6)/4H-G-S/ C/7 C DATA MODEL1/' ',' ',' ',' ',' G ',' S '/, C 1 MODEL2/' G ',' S ','G-S ','S-G ','-S-G','-G-S'/ C/ C C----------------------------------------------------------------------- C PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IV1 = IV(1) OL = IV(OUTLEV) IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 140 IF (OL .EQ. 0) GO TO 20 IF (IV1 .GE. 12) GO TO 20 IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 20 IF (IV1 .GT. 2) GO TO 10 IV(PRNTIT) = IV(PRNTIT) + 1 IF (IV(PRNTIT) .LT. IABS(OL)) GO TO 999 10 NF = IV(NFCALL) - IABS(IV(NFCOV)) IV(PRNTIT) = 0 RELDF = ZERO PRELDF = ZERO OLDF = V(F0) IF (OLDF .LE. ZERO) GO TO 12 RELDF = V(FDIF) / OLDF PRELDF = V(PREDUC) / OLDF 12 IF (OL .GT. 0) GO TO 15 C C *** PRINT SHORT SUMMARY LINE *** C IF (IV(NEEDHD) .EQ. 1) WRITE(PU, 1010) 1010 FORMAT(12H0 IT NF,6X,1HF,8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX) IV(NEEDHD) = 0 WRITE(PU,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX) GO TO 20 C C *** PRINT LONG SUMMARY LINE *** C 15 IF (IV(NEEDHD) .EQ. 1) WRITE(PU,1015) 1015 FORMAT(12H0 IT NF,6X,1HF,8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX, 1 4X,15HMODEL STPPAR,6X,4HSIZE,6X,6HD*STEP,5X,7HNPRELDF) IV(NEEDHD) = 0 M = IV(SUSED) NRELDF = ZERO IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF WRITE(PU,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 MODEL1(M), MODEL2(M), V(STPPAR), V(SIZE), 2 V(DSTNRM), NRELDF 1017 FORMAT(1X,I5,I6,4E11.3,A3,A4,4E11.3) C 20 GO TO (999,999,30,35,40,45,50,60,70,80,90,150,110,120,130), IV1 C 30 WRITE(PU,1030) 1030 FORMAT(26H0***** X-CONVERGENCE *****) GO TO 180 C 35 WRITE(PU,1035) 1035 FORMAT(42H0***** RELATIVE FUNCTION CONVERGENCE *****) GO TO 180 C 40 WRITE(PU,1040) 1040 FORMAT(49H0***** X- AND RELATIVE FUNCTION CONVERGENCE *****) GO TO 180 C 45 WRITE(PU,1045) 1045 FORMAT(42H0***** ABSOLUTE FUNCTION CONVERGENCE *****) GO TO 180 C 50 WRITE(PU,1050) 1050 FORMAT(33H0***** SINGULAR CONVERGENCE *****) GO TO 180 C 60 WRITE(PU,1060) 1060 FORMAT(30H0***** FALSE CONVERGENCE *****) GO TO 180 C 70 WRITE(PU,1070) 1070 FORMAT(38H0***** FUNCTION EVALUATION LIMIT *****) GO TO 180 C 80 WRITE(PU,1080) 1080 FORMAT(28H0***** ITERATION LIMIT *****) GO TO 180 C 90 WRITE(PU,1090) 1090 FORMAT(18H0***** STOPX *****) GO TO 180 C 110 WRITE(PU,1100) 1100 FORMAT(45H0***** INITIAL SUM OF SQUARES OVERFLOWS *****) C GO TO 150 C 120 WRITE(PU,1120) 1120 FORMAT(37H0***** BAD PARAMETERS TO ASSESS *****) GO TO 999 C 130 WRITE(PU,1130) 1130 FORMAT(36H0***** J COULD NOT BE COMPUTED *****) IF (IV(NITER) .GT. 0) GO TO 190 GO TO 150 C 140 WRITE(PU,1140) IV1 1140 FORMAT(14H0***** IV(1) =,I5,6H *****) GO TO 999 C C *** INITIAL CALL ON ITSMRY *** C 150 IF (IV(X0PRT) .NE. 0) WRITE(PU,1150) (I, X(I), D(I), I = 1, P) 1150 FORMAT(23H0 I INITIAL X(I),7X,4HD(I)//(1X,I5,E17.6,E14.3)) IF (IV1 .GE. 13) GO TO 999 IV(NEEDHD) = 0 IV(PRNTIT) = 0 IF (OL .EQ. 0) GO TO 999 IF (OL .LT. 0) WRITE(PU,1010) IF (OL .GT. 0) WRITE(PU,1015) WRITE(PU,1160) V(F) 1160 FORMAT(12H0 0 1,E11.3,11X,E11.3) GO TO 999 C C *** PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION *** C 180 IV(NEEDHD) = 1 IF (IV(STATPR) .EQ. 0) GO TO 190 OLDF = V(F0) PRELDF = ZERO NRELDF = ZERO IF (OLDF .LE. ZERO) GO TO 185 PRELDF = V(PREDUC) / OLDF NRELDF = V(NREDUC) / OLDF 185 NF = IV(NFCALL) - IV(NFCOV) NG = IV(NGCALL) - IV(NGCOV) WRITE(PU,1180) V(F), V(RELDX), NF, NG, PRELDF, NRELDF 1180 FORMAT(9H0FUNCTION,E17.6,8H RELDX,E20.6/12H FUNC. EVALS, 1 I8,9X,11HGRAD. EVALS,I8/7H PRELDF,E19.6,3X,7HNPRELDF,E18.6) C IF (IV(NFCOV) .GT. 0) WRITE(PU,1185) IV(NFCOV) 1185 FORMAT(1H0,I4,34H EXTRA FUNC. EVALS FOR COVARIANCE.) IF (IV(NGCOV) .GT. 0) WRITE(PU,1186) IV(NGCOV) 1186 FORMAT(1X,I4,34H EXTRA GRAD. EVALS FOR COVARIANCE.) C 190 IF (IV(SOLPRT) .EQ. 0) GO TO 210 IV(NEEDHD) = 1 G1 = IV(G) WRITE(PU,1190) 1190 FORMAT(22H0 I FINAL X(I),8X,4HD(I),10X,4HG(I)/) DO 200 I = 1, P WRITE(PU,1200) I, X(I), D(I), V(G1) G1 = G1 + 1 200 CONTINUE 1200 FORMAT(1X,I5,E17.6,2E14.3) C 210 IF (IV(COVPRT) .EQ. 0) GO TO 999 COV1 = IV(COVMAT) IV(NEEDHD) = 1 IF (COV1) 220, 230, 240 220 IF (-1 .EQ. COV1) WRITE(PU,1220) 1220 FORMAT(43H0++++++ INDEFINITE COVARIANCE MATRIX ++++++) IF (-2 .EQ. COV1) WRITE(PU,1225) 1225 FORMAT(52H0++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++) GO TO 999 C 230 WRITE(PU,1230) 1230 FORMAT(45H0++++++ COVARIANCE MATRIX NOT COMPUTED ++++++) GO TO 999 C 240 I = IABS(IV(COVREQ)) IF (I .LE. 1) WRITE(PU,1241) 1241 FORMAT(48H0COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/) IF (I .EQ. 2) WRITE(PU,1242) 1242 FORMAT(27H0COVARIANCE = SCALE * H**-1/) IF (I .GE. 3) WRITE(PU,1243) 1243 FORMAT(36H0COVARIANCE = SCALE * (J**T * J)**-1/) II = COV1 - 1 IF (OL .LE. 0) GO TO 260 DO 250 I = 1, P I1 = II + 1 II = II + I WRITE(PU,1250) I, (V(J), J = I1, II) 250 CONTINUE 1250 FORMAT(4H ROW,I3,2X,9E12.4/(9X,9E12.4)) GO TO 999 C 260 DO 270 I = 1, P I1 = II + 1 II = II + I WRITE(PU,1270) I, (V(J), J = I1, II) 270 CONTINUE 1270 FORMAT(4H ROW,I3,2X,5E12.4/(9X,5E12.4)) C 999 RETURN C *** LAST CARD OF ITSMRY FOLLOWS *** END SUBROUTINE LINVRT(N, LIN, L) LIN00010 C C *** COMPUTE LIN = L**-1, BOTH N X N LOWER TRIANG. STORED *** C *** COMPACTLY BY ROWS. LIN AND L MAY SHARE THE SAME STORAGE. *** C C *** PARAMETERS *** C INTEGER N REAL L(1), LIN(1) C DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1 REAL ONE, T, ZERO C/6 DATA ONE/1.E+0/, ZERO/0.E+0/ C/7 C PARAMETER (ONE=1.D+0, ZERO=0.D+0) C/ C C *** BODY *** C NP1 = N + 1 J0 = N*(NP1)/2 DO 30 II = 1, N I = NP1 - II LIN(J0) = ONE/L(J0) IF (I .LE. 1) GO TO 999 J1 = J0 IM1 = I - 1 DO 20 JJ = 1, IM1 T = ZERO J0 = J1 K0 = J1 - JJ DO 10 K = 1, JJ T = T - L(K0)*LIN(J0) J0 = J0 - 1 K0 = K0 + K - I 10 CONTINUE LIN(J0) = T/L(K0) 20 CONTINUE J0 = J0 - 1 30 CONTINUE 999 RETURN C *** LAST CARD OF LINVRT FOLLOWS *** END SUBROUTINE LITVMU(N, X, L, Y) LIT00010 C C *** SOLVE (L**T)*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N REAL X(N), L(1), Y(N) INTEGER I, II, IJ, IM1, I0, J, NP1 REAL XI, ZERO C/6 DATA ZERO/0.E+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C DO 10 I = 1, N 10 X(I) = Y(I) NP1 = N + 1 I0 = N*(N+1)/2 DO 30 II = 1, N I = NP1 - II XI = X(I)/L(I0) X(I) = XI IF (I .LE. 1) GO TO 999 I0 = I0 - I IF (XI .EQ. ZERO) GO TO 30 IM1 = I - 1 DO 20 J = 1, IM1 IJ = I0 + J X(J) = X(J) - XI*L(IJ) 20 CONTINUE 30 CONTINUE 999 RETURN C *** LAST CARD OF LITVMU FOLLOWS *** END SUBROUTINE LIVMUL(N, X, L, Y) LIV00010 C C *** SOLVE L*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N REAL X(N), L(1), Y(N) EXTERNAL DOTPRD REAL DOTPRD INTEGER I, J, K REAL T, ZERO C/6 DATA ZERO/0.E+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C DO 10 K = 1, N IF (Y(K) .NE. ZERO) GO TO 20 X(K) = ZERO 10 CONTINUE GO TO 999 20 J = K*(K+1)/2 X(K) = Y(K) / L(J) IF (K .GE. N) GO TO 999 K = K + 1 DO 30 I = K, N T = DOTPRD(I-1, L(J+1), X) J = J + I X(I) = (Y(I) - T)/L(J) 30 CONTINUE 999 RETURN C *** LAST CARD OF LIVMUL FOLLOWS *** END SUBROUTINE LMSTEP(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W) LMS00010 C C *** COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE ** C *** NL2SOL VERSION 2.2. *** C C *** PARAMETER DECLARATIONS *** C INTEGER IERR, KA, P INTEGER IPIVOT(P) REAL D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1) C DIMENSION W(P*(P+5)/2 + 4) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN C MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING C RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG- C MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE- C TECHNIQUE. C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR. C G (IN) = THE GRADIENT VECTOR (J**T)*R. C IERR (I/O) = RETURN CODE FROM QRFACT OR QRFGS -- 0 MEANS R HAS C FULL RANK. C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR QRFGS, WHICH COMPUTE C QR DECOMPOSITIONS WITH COLUMN PIVOTING. C KA (I/O). KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON C LMSTEP FOR THE CURRENT R AND QTR. ON OUTPUT KA CON- C TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE C STEP. KA = 0 MEANS A GAUSS-NEWTON STEP. C P (IN) = NUMBER OF PARAMETERS. C QTR (IN) = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR. C R (IN) = THE R MATRIX, STORED COMPACTLY BY COLUMNS. C STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (I/O) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS C TWONORM(R - J*STEP)**2. (SEE ALGORITHM NOTES BELOW.) C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C FOR A GAUSS-NEWTON STEP. C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C BY THE STEP RETURNED. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL C CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS). C C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY MANY PARAMETERS ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE C WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P, C QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0). C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST- C SQUARES) PACKAGE (REF. 1). C C *** ALGORITHM NOTES *** C C THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN C REFS. 2 AND 4. FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60- C 62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER. C A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS) C IS SUFFICIENTLY LARGE. IN THIS CASE THE STEP RETURNED IS SUCH C THAT TWONORM(R)**2 - TWONORM(R - J*STEP)**2 DIFFERS FROM ITS C OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE, C WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL. (SEE C REF. 2 FOR MORE DETAILS.) C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS. C LITVMU - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C LIVMUL - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C VCOPY - COPIES ONE VECTOR TO ANOTHER. C V2NORM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, C 186-197. C 3. LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES C PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J. C 4. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN, 1 PP1O2, RES, RES0, RMAT, RMAT0, UK0 REAL A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2, 1 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, 2 SI, SJ, SQRTAK, T, TWOPSI, UK, WL C C *** CONSTANTS *** REAL DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE, 1 TTOL, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS REAL ABS, AMAX1, AMIN1, SQRT C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL DOTPRD, LITVMU, LIVMUL, VCOPY, V2NORM REAL DOTPRD, V2NORM C C *** SUBSCRIPTS FOR V *** C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC, 1 PHMXFC, PREDUC, RADIUS, RAD0, STPPAR C/6 DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, 1 GTSTEP/4/, NREDUC/6/, PHMNFC/20/, 2 PHMXFC/21/, PREDUC/7/, RADIUS/8/, 3 RAD0/9/, STPPAR/5/ C/7 C PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, C 1 GTSTEP=4, NREDUC=6, PHMNFC=20, C 2 PHMXFC=21, PREDUC=7, RADIUS=8, C 3 RAD0=9, STPPAR=5) C/ C C/6 DATA DFAC/256.E+0/, EIGHT/8.E+0/, HALF/0.5E+0/, NEGONE/-1.E+0/, 1 ONE/1.E+0/, P001/1.E-3/, THREE/3.E+0/, TTOL/2.5E+0/, 2 ZERO/0.E+0/ C/7 C PARAMETER (DFAC=256.D+0, EIGHT=8.D+0, HALF=0.5D+0, NEGONE=-1.D+0, C 1 ONE=1.D+0, P001=1.D-3, THREE=3.D+0, TTOL=2.5D+0, C 2 ZERO=0.D+0) C/ C C *** BODY *** C C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK, C *** THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J) C *** AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0), C *** W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY. LK0 = P + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 RMAT0 = DSTSAV C *** A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS C *** STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL C *** VECTOR IS STORED IN W STARTING AT W(RES). THE LOOPS BELOW C *** THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER C *** WORK ON THESE COPIES. RMAT = RMAT0 + 1 PP1O2 = P * (P + 1) / 2 RES0 = PP1O2 + RMAT0 RES = RES0 + 1 RAD = V(RADIUS) IF (RAD .GT. ZERO) 1 PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2) PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD C *** DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS C *** REPRESENTATION OF THE UPDATED QR DECOMPOSITION. DTOL = ONE/DFAC DFACSQ = DFAC*DFAC C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO LK = ZERO UK = ZERO KALIM = KA + 12 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA) 10, 20, 370 C C *** FRESH START -- COMPUTE V(NREDUC) *** C 10 KA = 0 KALIM = 12 K = P IF (IERR .NE. 0) K = IABS(IERR) - 1 V(NREDUC) = HALF*DOTPRD(K, QTR, QTR) C C *** SET UP TO TRY INITIAL GAUSS-NEWTON STEP *** C 20 V(DST0) = NEGONE IF (IERR .NE. 0) GO TO 90 C C *** COMPUTE GAUSS-NEWTON STEP *** C C *** NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN C *** R(1), R(2), R(3), ... IT IS THE TRANSPOSE OF A C *** LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE C *** TREAT IT AS SUCH WHEN USING LITVMU AND LIVMUL. CALL LITVMU(P, W, R, QTR) C *** TEMPORARILY STORE PERMUTED -D*STEP IN STEP. DO 60 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*W(I) 60 CONTINUE DST = V2NORM(P, STEP) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 410 C *** IF THIS IS A RESTART, GO TO 110 *** IF (KA .GT. 0) GO TO 110 C C *** GAUSS-NEWTON STEP WAS UNACCEPTABLE. COMPUTE L0 *** C DO 70 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*(STEP(I)/DST) 70 CONTINUE CALL LIVMUL(P, STEP, R, STEP) T = ONE / V2NORM(P, STEP) W(PHIPIN) = (T/DST)*T LK = PHI*W(PHIPIN) C C *** COMPUTE U0 *** C 90 DO 100 I = 1, P 100 W(I) = G(I)/D(I) V(DGNORM) = V2NORM(P, W) UK = V(DGNORM)/RAD IF (UK .LE. ZERO) GO TO 390 C C *** ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER. WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD C C C *** TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES *** C 110 KA = KA + 1 CALL VCOPY(PP1O2, W(RMAT), R) CALL VCOPY(P, W(RES), QTR) C C *** SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR. *** C IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK) 1 ALPHAK = UK * AMAX1(P001, SQRT(LK/UK)) SQRTAK = SQRT(ALPHAK) DO 120 I = 1, P 120 W(I) = ONE C C *** ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS. *** C DO 270 I = 1, P C *** GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D. C *** (USE STEP TO STORE TEMPORARY ROW) *** L = I*(I+1)/2 + RMAT0 WL = W(L) D2 = ONE D1 = W(I) J1 = IPIVOT(I) ADI = SQRTAK*D(J1) IF (ADI .GE. ABS(WL)) GO TO 150 130 A = ADI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 150 W(I) = D1/T D2 = D2/T W(L) = T*WL A = -A DO 140 J1 = I, P L = L + J1 STEP(J1) = A*W(L) 140 CONTINUE GO TO 170 C 150 B = WL/ADI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 130 W(I) = D2/T D2 = D1/T W(L) = T*ADI DO 160 J1 = I, P L = L + J1 WL = W(L) STEP(J1) = -WL W(L) = A*WL 160 CONTINUE C 170 IF (I .EQ. P) GO TO 280 C C *** NOW USE GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW *** C IP1 = I + 1 DO 260 I1 = IP1, P L = I1*(I1+1)/2 + RMAT0 WL = W(L) SI = STEP(I1-1) D1 = W(I1) C C *** RESCALE ROW I1 IF NECESSARY *** C IF (D1 .GE. DTOL) GO TO 190 D1 = D1*DFACSQ WL = WL/DFAC K = L DO 180 J1 = I1, P K = K + J1 W(K) = W(K)/DFAC 180 CONTINUE C C *** USE GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW C 190 IF (ABS(SI) .GT. ABS(WL)) GO TO 220 IF (SI .EQ. ZERO) GO TO 260 200 A = SI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 220 W(L) = T*WL W(I1) = D1/T D2 = D2/T DO 210 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = WL + B*SJ STEP(J1) = SJ - A*WL 210 CONTINUE GO TO 240 C 220 B = WL/SI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 200 W(I1) = D2/T D2 = D1/T W(L) = T*SI DO 230 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = A*WL + SJ STEP(J1) = B*SJ - WL 230 CONTINUE C C *** RESCALE TEMP. ROW IF NECESSARY *** C 240 IF (D2 .GE. DTOL) GO TO 260 D2 = D2*DFACSQ DO 250 K = I1, P 250 STEP(K) = STEP(K)/DFAC 260 CONTINUE 270 CONTINUE C C *** COMPUTE STEP *** C 280 CALL LITVMU(P, W(RES), W(RMAT), W(RES)) C *** RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES) *** DO 290 I = 1, P J1 = IPIVOT(I) K = RES0 + I T = W(K) STEP(J1) = -T W(K) = T*D(J1) 290 CONTINUE DST = V2NORM(P, W(RES)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430 IF (OLDPHI .EQ. PHI) GO TO 430 OLDPHI = PHI C C *** CHECK FOR (AND HANDLE) SPECIAL CASE *** C IF (PHI .GT. ZERO) GO TO 310 IF (KA .GE. KALIM) GO TO 430 TWOPSI = ALPHAK*DST*DST - DOTPRD(P, STEP, G) IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310 V(STPPAR) = -ALPHAK GO TO 440 C C *** UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN *** C 300 IF (PHI .LT. ZERO) UK = AMIN1(UK, ALPHAK) GO TO 320 310 IF (PHI .LT. ZERO) UK = ALPHAK 320 DO 330 I = 1, P J1 = IPIVOT(I) K = RES0 + I STEP(I) = D(J1) * (W(K)/DST) 330 CONTINUE CALL LIVMUL(P, STEP, W(RMAT), STEP) DO 340 I = 1, P 340 STEP(I) = STEP(I) / SQRT(W(I)) T = ONE / V2NORM(P, STEP) ALPHAK = ALPHAK + T*PHI*T/RAD LK = AMAX1(LK, ALPHAK) GO TO 110 C C *** RESTART *** C 370 LK = W(LK0) UK = W(UK0) IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20 ALPHAK = ABS(V(STPPAR)) DST = W(DSTSAV) PHI = DST - RAD T = V(DGNORM)/RAD IF (RAD .GT. V(RAD0)) GO TO 380 C C *** SMALLER RADIUS *** UK = T IF (ALPHAK .LE. ZERO) LK = ZERO IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** BIGGER RADIUS *** 380 IF (ALPHAK .LE. ZERO .OR. UK .GT. T) UK = T LK = ZERO IF (V(DST0) .GT. ZERO) LK = AMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR) *** C 390 V(STPPAR) = ZERO DST = ZERO LK = ZERO UK = ZERO V(GTSTEP) = ZERO V(PREDUC) = ZERO DO 400 I = 1, P 400 STEP(I) = ZERO GO TO 450 C C *** ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W *** C 410 ALPHAK = ZERO DO 420 I = 1, P J1 = IPIVOT(I) STEP(J1) = -W(I) 420 CONTINUE C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 430 V(STPPAR) = ALPHAK 440 V(GTSTEP) = DOTPRD(P, STEP, G) V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP)) 450 V(DSTNRM) = DST W(DSTSAV) = DST W(LK0) = LK W(UK0) = UK V(RAD0) = RAD C 999 RETURN C C *** LAST CARD OF LMSTEP FOLLOWS *** END SUBROUTINE LSQRT(N1, N, L, A, IRC) LSQ00010 C C *** COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR L OF C *** A = L*(L**T), WHERE L AND THE LOWER TRIANGLE OF A ARE BOTH C *** STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE). C *** IRC = 0 MEANS ALL WENT WELL. IRC = J MEANS THE LEADING C *** PRINCIPAL J X J SUBMATRIX OF A IS NOT POSITIVE DEFINITE -- C *** AND L(J*(J+1)/2) CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL. C C *** PARAMETERS *** C INTEGER N1, N, IRC REAL L(1), A(1) C DIMENSION L(N*(N+1)/2), A(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K REAL T, TD, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ REAL SQRT C/ C/6 DATA ZERO/0.E+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C C *** BODY *** C I0 = N1 * (N1 - 1) / 2 DO 50 I = N1, N TD = ZERO IF (I .EQ. 1) GO TO 40 J0 = 0 IM1 = I - 1 DO 30 J = 1, IM1 T = ZERO IF (J .EQ. 1) GO TO 20 JM1 = J - 1 DO 10 K = 1, JM1 IK = I0 + K JK = J0 + K T = T + L(IK)*L(JK) 10 CONTINUE 20 IJ = I0 + J J0 = J0 + J T = (A(IJ) - T) / L(J0) L(IJ) = T TD = TD + T*T 30 CONTINUE 40 I0 = I0 + I T = A(I0) - TD IF (T .LE. ZERO) GO TO 60 L(I0) = SQRT(T) 50 CONTINUE C IRC = 0 GO TO 999 C 60 L(I0) = T IRC = I C 999 RETURN C C *** LAST CARD OF LSQRT *** END REAL FUNCTION LSVMIN(P, L, X, Y) LSV00010 C C *** ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L C C *** PARAMETER DECLARATIONS *** C INTEGER P REAL L(1), X(P), Y(P) C DIMENSION L(P*(P+1)/2) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L. C C *** PARAMETER DESCRIPTION *** C C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX. C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E. C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC. C X (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED C APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE C SMALLEST SINGULAR VALUE. THIS APPROXIMATION MAY BE VERY C CRUDE. IF LSVMIN RETURNS ZERO, THEN SOME COMPONENTS OF X C ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES. C Y (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN C UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND- C ING TO THE SMALLEST SINGULAR VALUE. THIS APPROXIMATION C MAY BE CRUDE. IF LSVMIN RETURNS ZERO, THEN Y RETAINS ITS C INPUT VALUE. THE CALLER MAY PASS THE SAME VECTOR FOR X C AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER- C WRITES X (FOR NONZERO LSVMIN RETURNS). C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THERE ARE NO USAGE RESTRICTIONS. C C *** ALGORITHM NOTES *** C C THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT C LSVMIN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L C (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE C LARGEST. THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED C IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE C (2) AND (3). C C *** SUBROUTINES AND FUNCTIONS CALLED *** C C V2NORM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR. C C *** REFERENCES *** C C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977), C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY. C C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW, C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV. C C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2 C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS. C C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18, C PP. 586-593. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PPLUS1 REAL B, PSJ, SMINUS, SPLUS, T, XMINUS, XPLUS C C *** CONSTANTS *** C REAL HALF, ONE, R9973, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER MOD REAL ABS, FLOAT C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL V2NORM REAL V2NORM C C/6 DATA HALF/0.5E+0/, ONE/1.E+0/, R9973/9973.E+0/, ZERO/0.E+0/ C/7 C PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0) C SAVE IX C/ DATA IX/2/ C C *** BODY *** C C *** FIRST CHECK WHETHER TO RETURN LSVMIN = 0 AND INITIALIZE X *** C II = 0 DO 10 I = 1, P X(I) = ZERO II = II + I IF (L(II) .EQ. ZERO) GO TO 300 10 CONTINUE IF (MOD(IX, 9973) .EQ. 0) IX = 2 PPLUS1 = P + 1 C C *** SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE. C C DO J = P TO 1 BY -1... DO 100 JJJ = 1, P J = PPLUS1 - JJJ C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I. IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) XPLUS = (B - X(J)) XMINUS = (-B - X(J)) SPLUS = ABS(XPLUS) SMINUS = ABS(XMINUS) JM1 = J - 1 J0 = J*JM1/2 JJ = J0 + J XPLUS = XPLUS/L(JJ) XMINUS = XMINUS/L(JJ) IF (JM1 .EQ. 0) GO TO 30 DO 20 I = 1, JM1 JI = J0 + I SPLUS = SPLUS + ABS(X(I) + L(JI)*XPLUS) SMINUS = SMINUS + ABS(X(I) + L(JI)*XMINUS) 20 CONTINUE 30 IF (SMINUS .GT. SPLUS) XPLUS = XMINUS X(J) = XPLUS C *** UPDATE PARTIAL SUMS *** IF (JM1 .EQ. 0) GO TO 100 DO 40 I = 1, JM1 JI = J0 + I X(I) = X(I) + L(JI)*XPLUS 40 CONTINUE 100 CONTINUE C C *** NORMALIZE X *** C T = ONE/V2NORM(P, X) DO 110 I = 1, P 110 X(I) = T*X(I) C C *** SOLVE L*Y = X AND RETURN SVMIN = 1/TWONORM(Y) *** C DO 200 J = 1, P PSJ = ZERO JM1 = J - 1 J0 = J*JM1/2 IF (JM1 .EQ. 0) GO TO 130 DO 120 I = 1, JM1 JI = J0 + I PSJ = PSJ + L(JI)*Y(I) 120 CONTINUE 130 JJ = J0 + J Y(J) = (X(J) - PSJ)/L(JJ) 200 CONTINUE C LSVMIN = ONE/V2NORM(P, Y) GO TO 999 C 300 LSVMIN = ZERO 999 RETURN C *** LAST CARD OF LSVMIN FOLLOWS *** END SUBROUTINE LTSQAR(N, A, L) LTS00010 C C *** SET A TO LOWER TRIANGLE OF (L**T) * L *** C C *** L = N X N LOWER TRIANG. MATRIX STORED ROWWISE. *** C *** A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L. *** C INTEGER N REAL A(1), L(1) C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2) C INTEGER I, II, IIM1, I1, J, K, M REAL LII, LJ C II = 0 DO 50 I = 1, N I1 = II + 1 II = II + I M = 1 IF (I .EQ. 1) GO TO 30 IIM1 = II - 1 DO 20 J = I1, IIM1 LJ = L(J) DO 10 K = I1, J A(M) = A(M) + LJ*L(K) M = M + 1 10 CONTINUE 20 CONTINUE 30 LII = L(II) DO 40 J = I1, II 40 A(J) = LII * L(J) 50 CONTINUE C 999 RETURN C *** LAST CARD OF LTSQAR FOLLOWS *** END SUBROUTINE PARCHK(IV, N, NN, P, V) PAR00010 C C *** CHECK NL2SOL (VERSION 2.2) PARAMETERS, PRINT CHANGED VALUES *** C INTEGER IV(1), N, NN, P REAL V(1) C DIMENSION IV(*), V(*) C EXTERNAL DFAULT, RMDCON, VCOPY REAL RMDCON C DFAULT -- SUPPLIES DFAULT PARAMETER VALUES. C RMDCON -- RETURNS MACHINE-DEPENDENT CONSTANTS. C VCOPY -- COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C INTEGER I, IV1, JTOLP, K, L, M, NVDFLT, PU C/6 REAL CNGD(3), DFLT(3), VN(2,27), WHICH(3) C/7 C CHARACTER*4 CNGD(3), DFLT(3), VN(2,27), WHICH(3) C/ REAL BIG, MACHEP, TINY, VK, VM(27), VX(27), ZERO C C *** IV AND V SUBSCRIPTS *** C INTEGER DTYPE, DTYPE0, D0INIT, EPSLON, INITS, JTINIT, JTOL0, 1 JTOL1, OLDN, OLDNN, OLDP, PARPRT, PARSV1, PRUNIT C C/6 DATA NVDFLT/27/, ZERO/0.E+0/ C/7 C PARAMETER (NVDFLT=27, ZERO=0.D+0) C/ C C/6 DATA DTYPE/16/, DTYPE0/29/, D0INIT/37/, EPSLON/19/, 1 INITS/25/, JTINIT/39/, JTOL0/86/, JTOL1/87/, 2 OLDN/45/, OLDNN/46/, OLDP/47/, PARPRT/20/, 3 PARSV1/51/, PRUNIT/21/ C/7 C PARAMETER (DTYPE=16, DTYPE0=29, D0INIT=37, EPSLON=19, C 1 INITS=25, JTINIT=39, JTOL0=86, JTOL1=87, C 2 OLDN=45, OLDNN=46, OLDP=47, PARPRT=20, C 3 PARSV1=51, PRUNIT=21) C SAVE BIG, TINY C/ C DATA BIG/0.E+0/, TINY/1.E+0/ C/6 DATA VN(1,1),VN(2,1)/4HEPSL,4HON../ DATA VN(1,2),VN(2,2)/4HPHMN,4HFC../ DATA VN(1,3),VN(2,3)/4HPHMX,4HFC../ DATA VN(1,4),VN(2,4)/4HDECF,4HAC../ DATA VN(1,5),VN(2,5)/4HINCF,4HAC../ DATA VN(1,6),VN(2,6)/4HRDFC,4HMN../ DATA VN(1,7),VN(2,7)/4HRDFC,4HMX../ DATA VN(1,8),VN(2,8)/4HTUNE,4HR1../ DATA VN(1,9),VN(2,9)/4HTUNE,4HR2../ DATA VN(1,10),VN(2,10)/4HTUNE,4HR3../ DATA VN(1,11),VN(2,11)/4HTUNE,4HR4../ DATA VN(1,12),VN(2,12)/4HTUNE,4HR5../ DATA VN(1,13),VN(2,13)/4HAFCT,4HOL../ DATA VN(1,14),VN(2,14)/4HRFCT,4HOL../ DATA VN(1,15),VN(2,15)/4HXCTO,4HL.../ DATA VN(1,16),VN(2,16)/4HXFTO,4HL.../ DATA VN(1,17),VN(2,17)/4HLMAX,4H0.../ DATA VN(1,18),VN(2,18)/4HDLTF,4HDJ../ DATA VN(1,19),VN(2,19)/4HD0IN,4HIT../ DATA VN(1,20),VN(2,20)/4HDINI,4HT.../ DATA VN(1,21),VN(2,21)/4HJTIN,4HIT../ DATA VN(1,22),VN(2,22)/4HDLTF,4HDC../ DATA VN(1,23),VN(2,23)/4HDFAC,4H..../ DATA VN(1,24),VN(2,24)/4HRLIM,4HIT../ DATA VN(1,25),VN(2,25)/4HCOSM,4HIN../ DATA VN(1,26),VN(2,26)/4HDELT,4HA0../ DATA VN(1,27),VN(2,27)/4HFUZZ,4H..../ C/7 C DATA VN(1,1),VN(2,1)/'EPSL','ON..'/ C DATA VN(1,2),VN(2,2)/'PHMN','FC..'/ C DATA VN(1,3),VN(2,3)/'PHMX','FC..'/ C DATA VN(1,4),VN(2,4)/'DECF','AC..'/ C DATA VN(1,5),VN(2,5)/'INCF','AC..'/ C DATA VN(1,6),VN(2,6)/'RDFC','MN..'/ C DATA VN(1,7),VN(2,7)/'RDFC','MX..'/ C DATA VN(1,8),VN(2,8)/'TUNE','R1..'/ C DATA VN(1,9),VN(2,9)/'TUNE','R2..'/ C DATA VN(1,10),VN(2,10)/'TUNE','R3..'/ C DATA VN(1,11),VN(2,11)/'TUNE','R4..'/ C DATA VN(1,12),VN(2,12)/'TUNE','R5..'/ C DATA VN(1,13),VN(2,13)/'AFCT','OL..'/ C DATA VN(1,14),VN(2,14)/'RFCT','OL..'/ C DATA VN(1,15),VN(2,15)/'XCTO','L...'/ C DATA VN(1,16),VN(2,16)/'XFTO','L...'/ C DATA VN(1,17),VN(2,17)/'LMAX','0...'/ C DATA VN(1,18),VN(2,18)/'DLTF','DJ..'/ C DATA VN(1,19),VN(2,19)/'D0IN','IT..'/ C DATA VN(1,20),VN(2,20)/'DINI','T...'/ C DATA VN(1,21),VN(2,21)/'JTIN','IT..'/ C DATA VN(1,22),VN(2,22)/'DLTF','DC..'/ C DATA VN(1,23),VN(2,23)/'DFAC','....'/ C DATA VN(1,24),VN(2,24)/'RLIM','IT..'/ C DATA VN(1,25),VN(2,25)/'COSM','IN..'/ C DATA VN(1,26),VN(2,26)/'DELT','A0..'/ C DATA VN(1,27),VN(2,27)/'FUZZ','....'/ C/ C DATA VM(1)/1.0E-3/, VM(2)/-0.99E+0/, VM(3)/1.0E-3/, VM(4)/1.0E-2/, 1 VM(5)/1.2E+0/, VM(6)/1.E-2/, VM(7)/1.2E+0/, VM(8)/0.E+0/, 2 VM(9)/0.E+0/, VM(10)/1.E-3/, VM(11)/-1.E+0/, VM(15)/0.E+0/, 3 VM(16)/0.E+0/, VM(19)/0.E+0/, VM(20)/-10.E+0/, VM(21)/0.E+0/, 4 VM(23)/0.E+0/, VM(24)/1.E+10/, VM(27)/1.01E+0/ DATA VX(1)/0.9E+0/, VX(2)/-1.E-3/, VX(3)/1.E+1/, VX(4)/0.8E+0/, 1 VX(5)/1.E+2/, VX(6)/0.8E+0/, VX(7)/1.E+2/, VX(8)/0.5E+0/, 2 VX(9)/0.5E+0/, VX(10)/1.E+0/, VX(11)/1.E+0/, VX(14)/0.1E+0/, 3 VX(15)/1.E+0/, VX(16)/1.E+0/, VX(18)/1.E+0/, VX(22)/1.E+0/, 4 VX(23)/1.E+0/, VX(25)/1.E+0/, VX(26)/1.E+0/, VX(27)/1.E+2/ C C/6 DATA CNGD(1),CNGD(2),CNGD(3)/4H---C,4HHANG,4HED V/, 1 DFLT(1),DFLT(2),DFLT(3)/4HNOND,4HEFAU,4HLT V/ C/7 C DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/, C 1 DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/ C/ C C....................................................................... C IF (IV(1) .EQ. 0) CALL DFAULT(IV, V) PU = IV(PRUNIT) IV1 = IV(1) IF (IV1 .NE. 12) GO TO 30 IF (NN .GE. N .AND. N .GE. P .AND. P .GE. 1) GO TO 20 IV(1) = 16 IF (PU .NE. 0) WRITE(PU,10) NN, N, P 10 FORMAT(30H0///// BAD NN, N, OR P... NN =,I5,5H, N =,I5, 1 5H, P =,I5) GO TO 999 20 K = IV(21) CALL DFAULT(IV(21), V(33)) IV(21) = K IV(DTYPE0) = IV(DTYPE+20) IV(OLDN) = N IV(OLDNN) = NN IV(OLDP) = P WHICH(1) = DFLT(1) WHICH(2) = DFLT(2) WHICH(3) = DFLT(3) GO TO 80 30 IF (N .EQ. IV(OLDN) .AND. NN .EQ. IV(OLDNN) .AND. P .EQ. IV(OLDP)) 1 GO TO 50 IV(1) = 17 IF (PU .NE. 0) WRITE(PU,40) IV(OLDNN), IV(OLDN), IV(OLDP), NN, 1 N, P 40 FORMAT(30H0///// (NN,N,P) CHANGED FROM (,I5,1H,,I5,1H,,I3, 1 6H) TO (,I5,1H,,I5,1H,,I3,2H).) GO TO 999 C 50 IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 70 IV(1) = 50 IF (PU .NE. 0) WRITE(PU,60) IV1 60 FORMAT(15H0///// IV(1) =,I5,28H SHOULD BE BETWEEN 0 AND 12.) GO TO 999 C 70 WHICH(1) = CNGD(1) WHICH(2) = CNGD(2) WHICH(3) = CNGD(3) C 80 IF (BIG .GT. TINY) GO TO 90 TINY = RMDCON(1) MACHEP = RMDCON(3) BIG = RMDCON(6) VM(12) = MACHEP VX(12) = BIG VM(13) = TINY VX(13) = BIG VM(14) = MACHEP VM(17) = TINY VX(17) = BIG VM(18) = MACHEP VX(19) = BIG VX(20) = BIG VX(21) = BIG VM(22) = MACHEP VX(24) = RMDCON(5) VM(25) = MACHEP VM(26) = MACHEP 90 M = 0 IF (IV(INITS) .GE. 0 .AND. IV(INITS) .LE. 2) GO TO 110 M = 18 IF (PU .NE. 0) WRITE(PU,100) IV(INITS) 100 FORMAT(25H0///// INITS... IV(25) =,I4,20H SHOULD BE BETWEEN 0, 1 7H AND 2.) 110 K = EPSLON DO 140 I = 1, NVDFLT VK = V(K) IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 130 M = K IF (PU .NE. 0) WRITE(PU,120) VN(1,I), VN(2,I), K, VK, 1 VM(I), VX(I) 120 FORMAT(8H0///// ,2A4,5H.. V(,I2,3H) =,E11.3,7H SHOULD, 1 11H BE BETWEEN,E11.3,4H AND,D11.3) 130 K = K + 1 140 CONTINUE C IF (IV1 .EQ. 12 .AND. V(JTINIT) .GT. ZERO) GO TO 170 C C *** CHECK JTOL VALUES *** C JTOLP = JTOL0 + P DO 160 I = JTOL1, JTOLP IF (V(I) .GT. ZERO) GO TO 160 K = I - JTOL0 IF (PU .NE. 0) WRITE(PU,150) K, I, V(I) 150 FORMAT(12H0///// JTOL(,I3,6H) = V(,I3,3H) =,E11.3, 1 20H SHOULD BE POSITIVE.) M = I 160 CONTINUE C 170 IF (M .EQ. 0) GO TO 180 IV(1) = M GO TO 999 C 180 IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999 IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. 0) GO TO 200 M = 1 WRITE(PU,190) IV(INITS) 190 FORMAT(22H0NONDEFAULT VALUES..../20H INITS..... IV(25) =,I3) 200 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 210 IF (M .EQ. 0) WRITE(PU,215) WHICH M = 1 WRITE(PU,205) IV(DTYPE) 205 FORMAT(20H DTYPE..... IV(16) =,I3) 210 K = EPSLON L = PARSV1 DO 240 I = 1, NVDFLT IF (V(K) .EQ. V(L)) GO TO 230 IF (M .EQ. 0) WRITE(PU,215) WHICH 215 FORMAT(1H0,3A4,9HALUES..../) M = 1 WRITE(PU,220) VN(1,I), VN(2,I), K, V(K) 220 FORMAT(1X,2A4,5H.. V(,I2,3H) =,E15.7) 230 K = K + 1 L = L + 1 240 CONTINUE IV(DTYPE0) = IV(DTYPE) CALL VCOPY(NVDFLT, V(PARSV1), V(EPSLON)) IF (IV1 .NE. 12) GO TO 999 IF (V(JTINIT) .GT. ZERO) GO TO 260 JTOLP = JTOL0 + P WRITE(PU,250) (V(I), I = JTOL1, JTOLP) 250 FORMAT(24H0(INITIAL) JTOL ARRAY.../(1X,6E12.3)) 260 IF (V(D0INIT) .GT. ZERO) GO TO 999 K = JTOL1 + P L = K + P - 1 WRITE(PU,270) (V(I), I = K, L) 270 FORMAT(22H0(INITIAL) D0 ARRAY.../1X,6E12.3) C 999 RETURN C *** LAST CARD OF PARCHK FOLLOWS *** END SUBROUTINE QAPPLY(NN, N, P, J, R, IERR) QAP00010 C *****PARAMETERS. INTEGER NN, N, P, IERR REAL J(NN,P), R(N) C C .................................................................. C .................................................................. C C *****PURPOSE. C THIS SUBROUTINE APPLIES TO R THE ORTHOGONAL TRANSFORMATIONS C STORED IN J BY QRFACT C C *****PARAMETER DESCRIPTION. C ON INPUT. C C NN IS THE ROW DIMENSION OF THE MATRIX J AS DECLARED IN C THE CALLING PROGRAM DIMENSION STATEMENT C C N IS THE NUMBER OF ROWS OF J AND THE SIZE OF THE VECTOR R C C P IS THE NUMBER OF COLUMNS OF J AND THE SIZE OF SIGMA C C J CONTAINS ON AND BELOW ITS DIAGONAL THE COLUMN VECTORS C U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS C IDENT - U*U.TRANSPOSE C C R IS THE RIGHT HAND SIDE VECTOR TO WHICH THE ORTHOGONAL C TRANSFORMATIONS WILL BE APPLIED C C IERR IF NON-ZERO INDICATES THAT NOT ALL THE TRANSFORMATIONS C WERE SUCCESSFULLY DETERMINED AND ONLY THE FIRST C ABS(IERR) - 1 TRANSFORMATIONS WILL BE USED C C ON OUTPUT. C C R HAS BEEN OVERWRITTEN BY ITS TRANSFORMED IMAGE C C *****APPLICATION AND USAGE RESTRICTIONS. C NONE C C *****ALGORITHM NOTES. C THE VECTORS U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS C ARE NORMALIZED SO THAT THEIR 2-NORM SQUARED IS 2. THE USE OF C THESE TRANSFORMATIONS HERE IS IN THE SPIRIT OF (1). C C *****SUBROUTINES AND FUNCTIONS CALLED. C C DOTPRD - FUNCTION, RETURNS THE INNER PRODUCT OF VECTORS C C *****REFERENCES. C (1) BUSINGER, P. A., AND GOLUB, G. H. (1965), LINEAR LEAST SQUARES C SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7, C PP. 269-276. C C *****HISTORY. C DESIGNED BY DAVID M. GAY, CODED BY STEPHEN C. PETERS (WINTER 1977) C C *****GENERAL. C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C .................................................................. C .................................................................. C C *****LOCAL VARIABLES. INTEGER I, K, L, NL1 REAL T C *****INTRINSIC FUNCTIONS. C/+ INTEGER IABS C/ C *****FUNCTIONS. EXTERNAL DOTPRD REAL DOTPRD C K = P IF (IERR .NE. 0) K = IABS(IERR) - 1 IF ( K .EQ. 0) GO TO 999 C DO 20 L = 1, K NL1 = N - L + 1 T = -DOTPRD(NL1, J(L,L), R(L)) C DO 10 I = L, N 10 R(I) = R(I) + T*J(I,L) 20 CONTINUE 999 RETURN C .... LAST CARD OF QAPPLY ......................................... END SUBROUTINE QRFACT(NM,M,N,QR,ALPHA,IPIVOT,IERR,NOPIVK,SUM) QRF00010 C C *** COMPUTE THE QR DECOMPOSITION OF THE MATRIX STORED IN QR *** C C *****PARAMETERS. INTEGER NM,M,N,IPIVOT(N),IERR,NOPIVK REAL QR(NM,N),ALPHA(N),SUM(N) C *****LOCAL VARIABLES. INTEGER I,J,JBAR,K,K1,MINUM,MK1 REAL ALPHAK,BETA,QRKK,QRKMAX,SIGMA,TEMP,UFETA,RKTOL, 1 RKTOL1,SUMJ C *****FUNCTIONS. C/+ INTEGER MIN0 REAL ABS,SQRT C/ EXTERNAL DOTPRD, RMDCON, VAXPY, VSCOPY, V2NORM REAL DOTPRD, RMDCON, V2NORM C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS. C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS. C VAXPY... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V2NORM... RETURNS THE 2-NORM OF A VECTOR. C C *****CONSTANTS. REAL ONE, P01, P99, ZERO C/6 DATA ONE/1.0E+0/, P01/0.01E+0/, P99/0.99E+0/, ZERO/0.0E+0/ C/7 C PARAMETER (ONE=1.0D+0, P01=0.01D+0, P99=0.99D+0, ZERO=0.0D+0) C SAVE RKTOL, UFETA C/ C C C .................................................................. C .................................................................. C C C *****PURPOSE. C C THIS SUBROUTINE DOES A QR-DECOMPOSITION ON THE M X N MATRIX QR, C WITH AN OPTIONALLY MODIFIED COLUMN PIVOTING, AND RETURNS THE C UPPER TRIANGULAR R-MATRIX, AS WELL AS THE ORTHOGONAL VECTORS C USED IN THE TRANSFORMATIONS. C C *****PARAMETER DESCRIPTION. C ON INPUT. C C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C M MUST BE SET TO THE NUMBER OF ROWS IN THE MATRIX. C C N MUST BE SET TO THE NUMBER OF COLUMNS IN THE MATRIX. C C QR CONTAINS THE REAL RECTANGULAR MATRIX TO BE DECOMPOSED. C C NOPIVK IS USED TO CONTROL PIVOTTING. COLUMNS 1 THROUGH C NOPIVK WILL REMAIN FIXED IN POSITION. C C SUM IS USED FOR TEMPORARY STORAGE FOR THE SUBROUTINE. C C ON OUTPUT. C C QR CONTAINS THE NON-DIAGONAL ELEMENTS OF THE R-MATRIX C IN THE STRICT UPPER TRIANGLE. THE VECTORS U, WHICH C DEFINE THE HOUSEHOLDER TRANSFORMATIONS I - U*U-TRANSP, C ARE IN THE COLUMNS OF THE LOWER TRIANGLE. THESE VECTORS U C ARE SCALED SO THAT THE SQUARE OF THEIR 2-NORM IS 2.0. C C ALPHA CONTAINS THE DIAGONAL ELEMENTS OF THE R-MATRIX. C C IPIVOT REFLECTS THE COLUMN PIVOTING PERFORMED ON THE INPUT C MATRIX TO ACCOMPLISH THE DECOMPOSITION. THE J-TH C ELEMENT OF IPIVOT GIVES THE COLUMN OF THE ORIGINAL C MATRIX WHICH WAS PIVOTED INTO COLUMN J DURING THE C DECOMPOSITION. C C IERR IS SET TO. C 0 FOR NORMAL RETURN, C K IF NO NON-ZERO PIVOT COULD BE FOUND FOR THE K-TH C TRANSFORMATION, OR C -K FOR AN ERROR EXIT ON THE K-TH THANSFORMATION. C IF AN ERROR EXIT WAS TAKEN, THE FIRST (K - 1) C TRANSFORMATIONS ARE CORRECT. C C C *****APPLICATIONS AND USAGE RESTRICTIONS. C THIS MAY BE USED WHEN SOLVING LINEAR LEAST-SQUARES PROBLEMS -- C SEE SUBROUTINE QR1 OF ROSEPACK. IT IS CALLED FOR THIS PURPOSE C BY LLSQST IN THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE. C C *****ALGORITHM NOTES. C THIS VERSION OF QRFACT TRIES TO ELIMINATE THE OCCURRENCE OF C UNDERFLOWS DURING THE ACCUMULATION OF INNER PRODUCTS. RKTOL1 C IS CHOSEN BELOW SO AS TO INSURE THAT DISCARDED TERMS HAVE NO C EFFECT ON THE COMPUTED TWO-NORMS. C C ADAPTED FROM THE ALGOL ROUTINE SOLVE (1). C C *****REFERENCES. C (1) BUSINGER,P. AND GOLUB,G.H., LINEAR LEAST SQUARES C SOLUTIONS BY HOUSHOLDER TRANSFORMATIONS, IN WILKINSON,J.H. C AND REINSCH,C.(EDS.), HANDBOOK FOR AUTOMATIC COMPUTATION, C VOLUME II. LINEAR ALGEBRA, SPRINGER-VERLAG, 111-118 (1971). C PREPUBLISHED IN NUMER.MATH. 7, 269-276 (1965). C C *****HISTORY. C THIS AMOUNTS TO THE SUBROUTINE QR1 OF ROSEPACK WITH RKTOL1 USED C IN PLACE OF RKTOL BELOW, WITH V2NORM USED TO INITIALIZE (AND C SOMETIMES UPDATE) THE SUM ARRAY, AND WITH CALLS ON DOTPRD AND C VAXPY IN PLACE OF SOME LOOPS. C C *****GENERAL. C C DEVELOPMENT OF THIS PROGRAM SUPPORTED IN PART BY C NATIONAL SCIENCE FOUNDATION GRANT GJ-1154X3 AND C NATIONAL SCIENCE FOUNDATION GRANT DCR75-08802 C TO NATIONAL BUREAU OF ECONOMIC RESEARCH, INC. C C C C .................................................................. C .................................................................. C C C .......... UFETA IS THE SMALLEST POSITIVE FLOATING POINT NUMBER C S.T. UFETA AND -UFETA CAN BOTH BE REPRESENTED. C C .......... RKTOL IS THE SQUARE ROOT OF THE RELATIVE PRECISION C OF FLOATING POINT ARITHMETIC (MACHEP). DATA RKTOL/0.E+0/, UFETA/0.E+0/ C *****BODY OF PROGRAM. IF (UFETA .GT. ZERO) GO TO 10 UFETA = RMDCON(1) RKTOL = RMDCON(4) 10 IERR = 0 RKTOL1 = P01 * RKTOL C DO 20 J=1,N SUM(J) = V2NORM(M, QR(1,J)) IPIVOT(J) = J 20 CONTINUE C MINUM = MIN0(M,N) C DO 120 K=1,MINUM MK1 = M - K + 1 C ..........K-TH HOUSEHOLDER TRANSFORMATION.......... SIGMA = ZERO JBAR = 0 C ..........FIND LARGEST COLUMN SUM.......... IF (K .LE. NOPIVK) GO TO 50 DO 30 J=K,N IF (SIGMA .GE. SUM(J)) GO TO 30 SIGMA = SUM(J) JBAR = J 30 CONTINUE C IF (JBAR .EQ. 0) GO TO 220 IF (JBAR .EQ. K) GO TO 50 C ..........COLUMN INTERCHANGE.......... I = IPIVOT(K) IPIVOT(K) = IPIVOT(JBAR) IPIVOT(JBAR) = I SUM(JBAR) = SUM(K) SUM(K) = SIGMA C DO 40 I=1,M SIGMA = QR(I,K) QR(I,K) = QR(I,JBAR) QR(I,JBAR) = SIGMA 40 CONTINUE C ..........END OF COLUMN INTERCHANGE.......... 50 CONTINUE C .......... SECOND INNER PRODUCT .......... QRKMAX = ZERO C DO 60 I=K,M IF (ABS( QR(I,K) ) .GT. QRKMAX) QRKMAX = ABS( QR(I,K) ) 60 CONTINUE C IF (QRKMAX .LT. UFETA) GO TO 210 ALPHAK = V2NORM(MK1, QR(K,K)) / QRKMAX SIGMA = ALPHAK**2 C C .......... END SECOND INNER PRODUCT .......... QRKK = QR(K,K) IF (QRKK .GE. ZERO) ALPHAK = -ALPHAK ALPHA(K) = ALPHAK * QRKMAX BETA = QRKMAX * SQRT(SIGMA - (QRKK*ALPHAK/QRKMAX) ) QR(K,K) = QRKK - ALPHA(K) DO 65 I=K,M 65 QR(I,K) = QR(I,K) / BETA K1 = K + 1 IF (K1 .GT. N) GO TO 120 C DO 110 J = K1, N TEMP = -DOTPRD(MK1, QR(K,K), QR(K,J)) C C *** SET QR(I,J) = QR(I,J) + TEMP*QR(I,K), I = K,...,M. C CALL VAXPY(MK1, QR(K,J), TEMP, QR(K,K), QR(K,J)) C IF (K1 .GT. M) GO TO 110 SUMJ = SUM(J) IF (SUMJ .LT. UFETA) GO TO 110 TEMP = ABS(QR(K,J)/SUMJ) IF (TEMP .LT. RKTOL1) GO TO 110 IF (TEMP .GE. P99) GO TO 90 SUM(J) = SUMJ * SQRT(ONE - TEMP**2) GO TO 110 90 SUM(J) = V2NORM(M-K, QR(K1,J)) 110 CONTINUE C ..........END OF K-TH HOUSEHOLDER TRANSFORMATION.......... 120 CONTINUE C GO TO 999 C ..........ERROR EXIT ON K-TH TRANSFORMATION.......... 210 IERR = -K GO TO 230 C ..........NO NON-ZERO ACCEPTABLE PIVOT FOUND.......... 220 IERR = K 230 DO 240 I = K, N ALPHA(I) = ZERO IF (I .GT. K) CALL VSCOPY(I-K, QR(K,I), ZERO) 240 CONTINUE C ..........RETURN TO CALLER.......... 999 RETURN C ..........LAST CARD OF QRFACT.......... END REAL FUNCTION RELDST(P, D, X, X0) REL00010 C C *** COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0 *** C *** NL2SOL VERSION 2.2 *** C INTEGER P REAL D(P), X(P), X0(P) C/+ REAL ABS C/ INTEGER I REAL EMAX, T, XMAX, ZERO C/6 DATA ZERO/0.E+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C EMAX = ZERO XMAX = ZERO DO 10 I = 1, P T = ABS(D(I) * (X(I) - X0(I))) IF (EMAX .LT. T) EMAX = T T = D(I) * (ABS(X(I)) + ABS(X0(I))) IF (XMAX .LT. T) XMAX = T 10 CONTINUE RELDST = ZERO IF (XMAX .GT. ZERO) RELDST = EMAX / XMAX 999 RETURN C *** LAST CARD OF RELDST FOLLOWS *** END SUBROUTINE RPTMUL(FUNC, IPIVOT, J, NN, P, RD, X, Y, Z) RPT00010 C C *** FUNC = 1... SET Y = RMAT * (PERM**T) * X. C *** FUNC = 2... SET Y = PERM * (RMAT**T) * RMAT * (PERM**T) * X. C *** FUNC = 3... SET Y = PERM * (RMAT**T) X. C C C *** PERM = MATRIX WHOSE I-TH COL. IS THE IPIVOT(I)-TH UNIT VECTOR. C *** RMAT IS THE UPPER TRIANGULAR MATRIX WHOSE STRICT UPPER TRIANGLE C *** IS STORED IN J AND WHOSE DIAGONAL IS STORED IN RD. C *** Z IS A SCRATCH VECTOR. C *** X AND Y MAY SHARE STORAGE. C INTEGER FUNC, NN, P INTEGER IPIVOT(P) REAL J(NN,P), RD(P), X(P), Y(P), Z(P) C C *** LOCAL VARIABLES *** C INTEGER I, IM1, K, KM1 REAL ZK C C *** EXTERNAL FUNCTION *** C EXTERNAL DOTPRD REAL DOTPRD C C----------------------------------------------------------------------- C IF (FUNC .GT. 2) GO TO 50 C C *** FIRST SET Z = (PERM**T) * X *** C DO 10 I = 1, P K = IPIVOT(I) Z(I) = X(K) 10 CONTINUE C C *** NOW SET Y = RMAT * Z *** C Y(1) = Z(1) * RD(1) IF (P .LE. 1) GO TO 40 DO 30 K = 2, P KM1 = K - 1 ZK = Z(K) DO 20 I = 1, KM1 20 Y(I) = Y(I) + J(I,K)*ZK Y(K) = ZK*RD(K) 30 CONTINUE C 40 IF (FUNC .LE. 1) GO TO 999 GO TO 70 C 50 DO 60 I = 1, P 60 Y(I) = X(I) C C *** SET Z = (RMAT**T) * Y *** C 70 Z(1) = Y(1) * RD(1) IF (P .EQ. 1) GO TO 90 DO 80 I = 2, P IM1 = I - 1 Z(I) = Y(I)*RD(I) + DOTPRD(IM1, J(1,I), Y) 80 CONTINUE C C *** NOW SET Y = PERM * Z *** C 90 DO 100 I = 1, P K = IPIVOT(I) Y(K) = Z(I) 100 CONTINUE C 999 RETURN C *** LAST CARD OF RPTMUL FOLLOWS *** END SUBROUTINE SLUPDT(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE, SLU00010 1 Y) C C *** UPDATE SYMMETRIC A SO THAT A * STEP = Y *** C *** (LOWER TRIANGLE OF A STORED ROWWISE *** C C *** PARAMETER DECLARATIONS *** C INTEGER P REAL A(1), COSMIN, SIZE, STEP(P), U(P), W(P), 1 WCHMTD(P), WSCALE, Y(P) C DIMENSION A(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, J, K REAL DENMIN, SDOTWM, T, UI, WI C C *** CONSTANTS *** REAL HALF, ONE, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ REAL ABS, AMIN1 C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL DOTPRD, SLVMUL, V2NORM REAL DOTPRD, V2NORM C C/6 DATA HALF/0.5E+0/, ONE/1.E+0/, ZERO/0.E+0/ C/7 C PARAMETER (HALF=0.5D+0, ONE=1.D+0, ZERO=0.D+0) C/ C C----------------------------------------------------------------------- C SDOTWM = DOTPRD(P, STEP, WCHMTD) DENMIN = COSMIN * V2NORM(P,STEP) * V2NORM(P,WCHMTD) WSCALE = ONE IF (DENMIN .NE. ZERO) WSCALE = AMIN1(ONE, ABS(SDOTWM/DENMIN)) T = ZERO IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM DO 10 I = 1, P 10 W(I) = T * WCHMTD(I) CALL SLVMUL(P, U, A, STEP) T = HALF * (SIZE * DOTPRD(P, STEP, U) - DOTPRD(P, STEP, Y)) DO 20 I = 1, P 20 U(I) = T*W(I) + Y(I) - SIZE*U(I) C C *** SET A = A + U*(W**T) + W*(U**T) *** C K = 1 DO 40 I = 1, P UI = U(I) WI = W(I) DO 30 J = 1, I A(K) = SIZE*A(K) + UI*W(J) + WI*U(J) K = K + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST CARD OF SLUPDT FOLLOWS *** END SUBROUTINE SLVMUL(P, Y, S, X) SLV00010 C C *** SET Y = S * X, S = P X P SYMMETRIC MATRIX. *** C *** LOWER TRIANGLE OF S STORED ROWWISE. *** C C *** PARAMETER DECLARATIONS *** C INTEGER P REAL S(1), X(P), Y(P) C DIMENSION S(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IM1, J, K REAL XI C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTION *** C EXTERNAL DOTPRD REAL DOTPRD C C----------------------------------------------------------------------- C J = 1 DO 10 I = 1, P Y(I) = DOTPRD(I, S(J), X) J = J + I 10 CONTINUE C IF (P .LE. 1) GO TO 999 J = 1 DO 40 I = 2, P XI = X(I) IM1 = I - 1 J = J + 1 DO 30 K = 1, IM1 Y(K) = Y(K) + S(J)*XI J = J + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST CARD OF SLVMUL FOLLOWS *** END LOGICAL FUNCTION STOPX(IDUMMY) STO00010 C *****PARAMETERS... INTEGER IDUMMY C C .................................................................. C C *****PURPOSE... C THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION) C FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT C THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A C DYNAMIC STOPX. C C *****ALGORITHM NOTES... C AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED C INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A C FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT C (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX. C C .................................................................. C STOPX = .FALSE. RETURN END SUBROUTINE VAXPY(P, W, A, X, Y) VAX00010 C C *** SET W = A*X + Y -- W, X, Y = P-VECTORS, A = SCALAR *** C INTEGER P REAL A, W(P), X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 W(I) = A*X(I) + Y(I) RETURN END SUBROUTINE VCOPY(P, Y, X) VCO00010 C C *** SET Y = X, WHERE X AND Y ARE P-VECTORS *** C INTEGER P REAL X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = X(I) RETURN END SUBROUTINE VSCOPY(P, Y, S) VSC00010 C C *** SET P-VECTOR Y TO SCALAR S *** C INTEGER P REAL S, Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = S RETURN END REAL FUNCTION V2NORM(P, X) V2N00010 C C *** RETURN THE 2-NORM OF THE P-VECTOR X, TAKING *** C *** CARE TO AVOID THE MOST LIKELY UNDERFLOWS. *** C INTEGER P REAL X(P) C INTEGER I, J REAL ONE, R, SCALE, SQTETA, T, XI, ZERO C/+ REAL ABS, SQRT C/ EXTERNAL RMDCON REAL RMDCON C C/6 DATA ONE/1.E+0/, ZERO/0.E+0/ C/7 C PARAMETER (ONE=1.D+0, ZERO=0.D+0) C SAVE SQTETA C/ DATA SQTETA/0.E+0/ C IF (P .GT. 0) GO TO 10 V2NORM = ZERO GO TO 999 10 DO 20 I = 1, P IF (X(I) .NE. ZERO) GO TO 30 20 CONTINUE V2NORM = ZERO GO TO 999 C 30 SCALE = ABS(X(I)) IF (I .LT. P) GO TO 40 V2NORM = SCALE GO TO 999 40 T = ONE IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2) C C *** SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE C *** SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE. C *** THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS. C J = I + 1 DO 60 I = J, P XI = ABS(X(I)) IF (XI .GT. SCALE) GO TO 50 R = XI / SCALE IF (R .GT. SQTETA) T = T + R*R GO TO 60 50 R = SCALE / XI IF (R .LE. SQTETA) R = ZERO T = ONE + T * R*R SCALE = XI 60 CONTINUE C V2NORM = SCALE * SQRT(T) 999 RETURN C *** LAST CARD OF V2NORM FOLLOWS *** END C/////////////////////////////////////////////////////////////////////// C *** RUN NL2SOL ON VARIOUS TEST PROBLEMS, PRINT SUMMARY STATISTICS. NLM00010 C C *****COMMON STORAGE WITH NLTEST. C COMMON /TESTCM/ V, RS, JAC, NOUT, NPROB, XSCAL1, XSCAL2, IS, IV COMMON /TESTCH/ NAME, IRC INTEGER IS(6,50), IV(80), JAC, NOUT, NPROB, XSCAL1, XSCAL2 REAL RS(5,50) C/6 REAL NAME(2,50) INTEGER IRC(50) C/7 C CHARACTER NAME(2,50)*4, IRC(50)*1 C/ REAL V(1736) C C C .................................................................. C C *****PURPOSE. C THIS MAIN PROGRAM CALLS NLTEST TO RUN NL2SOL, THE NONLINEAR C LEAST-SQUARES SOLVER OF REF. 1, ON VARIOUS TEST PROBLEMS. C C C *****APPLICATION AND USAGE RESTRICTIONS. C THIS MAIN DRIVER IS INTENDED TO CHECK WHETHER THE NL2SOL C (NONLINEAR LEAST-SQUARES) PACKAGE WAS SUCCESSFULLY C TRANSPORTED TO A NEW MACHINE. C C *****ALGORITHM NOTES. C THE TEST PROBLEMS USED ARE FROM REFERENCES (2), (3), AND (4). C SOME ADDITIONAL TEST PROBLEMS WERE SUGGESTED BY JORGE MORE (PRI- C VATE COMMUNICATION). CALLS PASSING THESE PROBLEMS TO NLTEST HAVE C BEEN COMMENTED OUT (SINCE THERE ARE ENOUGH OTHER PROBLEMS), BUT C NOT REMOVED, SINCE THEY MAY BE OF INTEREST TO OTHER RESEARCHERS. C C *****FUNCTIONS AND SUBROUTINES CALLED. C C DFAULT - ESTABLISHES THE DEFAULT PARAMETER SETTINGS FOR C IV AND V. C C IMDCON - IMDCON(2) RETURNS I/O UNIT NUMBER ON WHICH NLTEST C WRITES A SUMMARY OF EACH TEST RUN. C C IVVSET - SUPPLIES NONDEFAULT VALUES FOR IV AND V. C C NLTEST - CALLS NL2SOL, THE NONLINEAR LEAST-SQUARES C PROBLEM SOLVER. C C TODAY - SUPPLIES DATE AND TIME (OR CURRENT VERSION OF NL2SOL). C C *****REFERENCES. C C (1). DENNIS, J.E.. GAY, D.M.. AND WELSCH, R.E. (1980), C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, C SUBMITTED TO ACM TRANS. MATH. SOFTWARE. C UNDER REVISION. C C (2). GILL, P.E.. AND MURRAY, W. (1976),ALGORITHMS FOR THE C SOLUTION OF THE NON-LINEAR LEAST-SQUARES PROBLEM, C NPL REPORT NAC71,(NATIONAL PHYSICAL LABORATORY, C DIVISION OF NUMERICAL ANALYSIS AND COMPUTING, C TEDDINGTON,MIDDLESEX,ENGLAND). C C (3) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS C OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING, C EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER, C ACADEMIC PRESS, NEW YORK. C C (4) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON- C LIKE METHOD BASED UPON GAUSSIAN ELIMINATION, C SIAM J. NUMER. ANAL. 6, PP. 560-569. C C *****GENERAL. C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C .................................................................. C .................................................................. C C *****INTRINSIC FUNCTIONS. C/+ INTEGER MOD REAL AMAX1 C/ C *****EXTERNAL FUNCTIONS AND SUBROUTINES. EXTERNAL DFAULT, IMDCON, IVVSET, NLTEST, TODAY INTEGER IMDCON C C *****LOCAL VARIABLES. LOGICAL RSTART INTEGER I, J, K, MXFCSV, MXITSV, PU C/6 INTEGER JTYP(2) REAL DATIME(4) C/7 C CHARACTER DATIME(4)*4, JTYP(2)*1 C/ C C/6 DATA RSTART/.FALSE./, JTYP(1),JTYP(2)/1H ,1H*/ C/7 C DATA RSTART/.FALSE./, JTYP(1),JTYP(2)/' ','*'/ C/ C C----------------------------------------------------------------------- C C *** ESTABLISH DEFAULT PARAMETER SETTINGS *** CALL DFAULT (IV, V) NOUT = IMDCON(2) C C *** NON-DEFAULT PARAMETER SETTINGS *** C CALL IVVSET(IV, V) PU = IV(21) C JAC = 1 NPROB = 0 XSCAL1 = 1 XSCAL2 = 3 C C/6 CALL NLTEST(2,2,1,4HROSN,4HBROK,RSTART) CALL NLTEST(3,3,2,4HHELI,4HX ,RSTART) CALL NLTEST(4,4,3,4HSING,4HULAR,RSTART) CALL NLTEST(7,4,4,4HWOOD,4HS ,RSTART) XSCAL2 = 1 CALL NLTEST(3,3,5,4HZANG,4HWILL,RSTART) XSCAL2 = 3 CALL NLTEST(5,3,6,4HENGV,4HALL ,RSTART) CALL NLTEST(2,2,7,4HBRAN,4HIN ,RSTART) XSCAL2 = 2 CALL NLTEST(3,2,8,4HBEAL,4HE ,RSTART) CALL NLTEST(5,4,9,4HCRAG,4HG ,RSTART) XSCAL2 = 2 CALL NLTEST(10,3,10,4HBOX ,4H ,RSTART) MXFCSV = IV(17) MXITSV = IV(18) IV(17) = 20 IV(18) = 15 XSCAL2 = 1 CALL NLTEST(15,15,11,4HDAVI,4HDON1,RSTART) IV(17) = MXFCSV IV(18) = MXITSV XSCAL2 = 3 CALL NLTEST(2,2,12,4HFRDS,4HTEIN,RSTART) XSCAL2 = 1 CALL NLTEST(31,6,13,4HWATS,4HON6 ,RSTART) CALL NLTEST(31,9,14,4HWATS,4HON9 ,RSTART) CALL NLTEST(31,12,15,4HWATS,4HON12,RSTART) MXFCSV = IV(17) IV(17) = 20 MXITSV = IV(18) IV(18) = 15 CALL NLTEST(31,20,16,4HWATS,4HON20,RSTART) IV(17) = MXFCSV IV(18) = MXITSV XSCAL2 = 2 CALL NLTEST(8,8,17,4HCHEB,4HQD8 ,RSTART) XSCAL2 = 3 CALL NLTEST(20,4,18,4HBROW,4HN ,RSTART) CALL NLTEST(15,3,19,4HBARD,4H ,RSTART) XSCAL2 = 1 CALL NLTEST(10,2,20,4HJENN,4HRICH,RSTART) XSCAL2 = 3 CALL NLTEST(11,4,21,4HKOWA,4HLIK ,RSTART) XSCAL2 = 1 CALL NLTEST(33,5,22,4HOSBO,4HRNE1,RSTART) XSCAL2 = 2 CALL NLTEST(65,11,23,4HOSBO,4HRNE2,RSTART) XSCAL2 = 3 CALL NLTEST(3,2,24,4HMADS,4HEN ,RSTART) XSCAL2 = 1 IV(17) = 400 IV(18) = 300 CALL NLTEST(16,3,25,4HMEYE,4HR ,RSTART) C/7 C CALL NLTEST(2,2,1,'ROSN','BROK',RSTART) C CALL NLTEST(3,3,2,'HELI','X ',RSTART) C CALL NLTEST(4,4,3,'SING','ULAR',RSTART) C CALL NLTEST(7,4,4,'WOOD','S ',RSTART) C XSCAL2 = 1 C CALL NLTEST(3,3,5,'ZANG','WILL',RSTART) C XSCAL2 = 3 C CALL NLTEST(5,3,6,'ENGV','ALL ',RSTART) C CALL NLTEST(2,2,7,'BRAN','IN ',RSTART) C XSCAL2 = 2 C CALL NLTEST(3,2,8,'BEAL','E ',RSTART) C CALL NLTEST(5,4,9,'CRAG','G ',RSTART) C XSCAL2 = 2 C CALL NLTEST(10,3,10,'BOX ',' ',RSTART) C MXFCSV = IV(17) C MXITSV = IV(18) C IV(17) = 20 C IV(18) = 15 C XSCAL2 = 1 C CALL NLTEST(15,15,11,'DAVI','DON1',RSTART) C IV(17) = MXFCSV C IV(18) = MXITSV C XSCAL2 = 3 C CALL NLTEST(2,2,12,'FRDS','TEIN',RSTART) C XSCAL2 = 1 C CALL NLTEST(31,6,13,'WATS','ON6 ',RSTART) C CALL NLTEST(31,9,14,'WATS','ON9 ',RSTART) C CALL NLTEST(31,12,15,'WATS','ON12',RSTART) C MXFCSV = IV(17) C IV(17) = 20 C MXITSV = IV(18) C IV(18) = 15 C CALL NLTEST(31,20,16,'WATS','ON20',RSTART) C IV(17) = MXFCSV C IV(18) = MXITSV C XSCAL2 = 2 C CALL NLTEST(8,8,17,'CHEB','QD8 ',RSTART) C XSCAL2 = 3 C CALL NLTEST(20,4,18,'BROW','N ',RSTART) C CALL NLTEST(15,3,19,'BARD',' ',RSTART) C XSCAL2 = 1 C CALL NLTEST(10,2,20,'JENN','RICH',RSTART) C XSCAL2 = 3 C CALL NLTEST(11,4,21,'KOWA','LIK ',RSTART) C XSCAL2 = 1 C CALL NLTEST(33,5,22,'OSBO','RNE1',RSTART) C XSCAL2 = 2 C CALL NLTEST(65,11,23,'OSBO','RNE2',RSTART) C XSCAL2 = 3 C CALL NLTEST(3,2,24,'MADS','EN ',RSTART) C XSCAL2 = 1 C IV(17) = 400 C IV(18) = 300 C CALL NLTEST(16,3,25,'MEYE','R ',RSTART) C/ C *** BROWN5 *** C CALL NLTEST(5,5,26,4HBROW,4HN5 ,RSTART) C *** BROWN10 *** C CALL NLTEST(10,10,27,4HBROW,4HN10 ,RSTART) C *** BROWN30 *** C CALL NLTEST(30,30,28,4HBROW,4HN30 ,RSTART) C *** BROWN40 *** C CALL NLTEST(40,40,29,4HBROW,4HN40 ,RSTART) C *** BARD+10 *** C CALL NLTEST(15,3,30,4HBARD,4H+10 ,RSTART) C *** KOWALIK AND OSBORNE + 10 *** C CALL NLTEST(11,4,31,4HKOWA,4HL+10,RSTART) C *** MEYER + 10 *** C CALL NLTEST(16,3,32,4HMEYE,4HR+10,RSTART) C *** WATSON6 + 10 *** C CALL NLTEST(31,6,33,4HWAT6,4H+10 ,RSTART) C *** WATSON9 + 10 *** C CALL NLTEST(31,9,34,4HWAT9,4H+10 ,RSTART) C *** WATSON12 + 10 *** C CALL NLTEST(31,12,35,4HWAT1,4H2+10,RSTART) C *** WATSON20 + 10 *** C CALL NLTEST(31,20,36,4HWAT2,4H0+10,RSTART) C C *** REPEAT TWO TESTS USING FINITE-DIFFERENCE JACOBIAN *** C JAC = 2 XSCAL2 = 1 C IV(17) = 50 IV(18) = 40 C/6 CALL NLTEST(2,2,1,4HROSN,4HBROK,RSTART) C/7 C CALL NLTEST(2,2,1,'ROSN','BROK',RSTART) C/ V(29) = AMAX1(1.0E-7, V(29)) IV(17) = 30 IV(18) = 20 C *** BROWN *** C/6 CALL NLTEST(20,4,18,4HBROW,4HN ,RSTART) C/7 C CALL NLTEST(20,4,18,'BROW','N ',RSTART) C/ C IF (NPROB .EQ. 0 .OR. PU .EQ. 0) STOP CALL TODAY(DATIME) DO 130 K = 1, NPROB IF (MOD(K,56) .EQ. 1) WRITE(PU, 110) DATIME, NPROB 110 FORMAT(1H1,11X,2A4,2X,2A4,10X,10HSUMMARY OF,I4, 1 22H NL2SOL TEST RUNS.....,10X, 2 32H(* = FINITE-DIFFERENCE JACOBIAN)/ 3 48H0 PROBLEM N P NITER NF NG IV1 X0SCAL,5X, 4 39HFINAL F PRELDF NRELDF RELDX/) J = IS(6,K) WRITE(PU,120) JTYP(J), NAME(1,K), NAME(2,K), 1 (IS(I,K), I=1,5), IRC(K), (RS(I,K), I=1,5) 120 FORMAT(1X,A1,2A4,2I4,I7,2I5,3X,A1,F9.1,E13.3,3E11.3) 130 CONTINUE C STOP C...... LAST CARD OF NLMAIN ............................................ END SUBROUTINE IVVSET(IV, V) IVV00010 C C *** SUPPLY NONDEFAULT IV AND V VALUES FOR NLMAIN (NL2SOL VER. 2.2). C INTEGER IV(24) REAL V(100) C C ACTIVATE THE NEXT LINE TO TURN OFF DETAILED SUMMARY PRINTING C IV(21) = 0 RETURN END SUBROUTINE NLTEST (N, P, NEX, TITLE1, TITLE2, RSTART) NLT00010 C C *** CALL NL2SOL, SAVE AND PRINT STATISTICS *** C C INTEGER N, P, NEX LOGICAL RSTART C/6 REAL TITLE1, TITLE2 C/7 C CHARACTER*4 TITLE1, TITLE2 C/ C COMMON /TESTCM/ V, RS, JAC, NOUT, NPROB, XSCAL1, XSCAL2, IS, IV COMMON /TESTCH/ NAME, IRC INTEGER IS(6,50), IV(80), JAC, NOUT, NPROB, XSCAL1, XSCAL2 REAL RS(5,50) C/6 INTEGER IRC(50) REAL NAME(2,50) C/7 C CHARACTER NAME(2,50)*4, IRC(50)*1 C/ REAL V(1736) C LOGICAL RSTRT INTEGER I, IRUN, PU, UIP(1) C/6 INTEGER ALG(2), JTYP(2), RC(10) REAL DATIME(4) C/7 C CHARACTER*4 DATIME(4) C CHARACTER*2 ALG(2) C CHARACTER*1 JTYP(2), RC(10) C/ REAL ONE, T, URPARM(1), X(20), X0SCAL, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL NL2SNO, NL2SOL, TESTR, TESTJ, TODAY, XINIT C C *** IV AND V SUBSCRIPTS *** C INTEGER F, F0, NFCALL, NFCOV, NGCALL, NITER, NREDUC, PREDUC, 1 PRUNIT, RELDX C C/6 DATA F/10/, F0/13/, NFCALL/6/, NFCOV/40/, NGCALL/30/, 1 NGCOV/41/, NITER/31/, NREDUC/6/, PREDUC/7/, 2 PRUNIT/21/, RELDX/17/ C/7 C PARAMETER (F=10, F0=13, NFCALL=6, NFCOV=40, NGCALL=30, C 1 NGCOV=41, NITER=31, NREDUC=6, PREDUC=7, C 2 PRUNIT=21, RELDX=17) C/ C/6 DATA ONE/1.E+0/, ZERO/0.E+0/ C/7 C PARAMETER (ONE=1.D+0, ZERO=0.D+0) C/ C/6 DATA ALG(1),ALG(2)/2HOL,2HNO/, JTYP(1),JTYP(2)/1H ,1H*/ DATA RC(1)/1H./, RC(2)/1H+/, RC(3)/1HX/, RC(4)/1HR/, RC(5)/1HB/, 1 RC(6)/1HA/, RC(7)/1HS/, RC(8)/1HF/, RC(9)/1HE/, RC(10)/1HI/ C/7 C DATA ALG(1),ALG(2)/'OL','NO'/, JTYP(1),JTYP(2)/' ','*'/ C DATA RC(1)/'.'/, RC(2)/'+'/, RC(3)/'X'/, RC(4)/'R'/, RC(5)/'B'/, C 1 RC(6)/'A'/, RC(7)/'S'/, RC(8)/'F'/, RC(9)/'E'/, RC(10)/'I'/ C/ C C----------------------------------------------------------------------- C UIP(1) = NEX RSTRT = RSTART IF (RSTRT) GO TO 20 PU = IV(PRUNIT) CALL TODAY(DATIME) IF (PU .NE. 0) WRITE(PU,10) ALG(JAC), TITLE1, TITLE2, DATIME 10 FORMAT (1H1//11H ***** NL2S,A2,12H ON PROBLEM ,2A4,6H *****,6X, 1 2A4,2X,2A4) C 20 DO 100 IRUN = XSCAL1, XSCAL2 IF (RSTRT) GO TO 40 IV(1) = 12 X0SCAL = 1.0E1 ** (IRUN-1) C C *** INITIALIZE THE SOLUTION VECTOR X *** CALL XINIT(P, X, NEX) DO 30 I = 1, P 30 X(I) = X0SCAL * X(I) C 40 IF (JAC .EQ. 1) 1 CALL NL2SOL(N,P,X,TESTR,TESTJ,IV,V,UIP,URPARM,TESTR) IF (JAC .EQ. 2) 1 CALL NL2SNO(N,P,X,TESTR,IV,V,UIP,URPARM,TESTR) IF (.NOT. RSTRT .AND. NPROB .LT. 50) NPROB = NPROB + 1 NAME(1,NPROB) = TITLE1 NAME(2,NPROB) = TITLE2 IS(1,NPROB) = N IS(2,NPROB) = P IS(3,NPROB) = IV(NITER) IS(4,NPROB) = IV(NFCALL) - IV(NFCOV) IS(5,NPROB) = IV(NGCALL) - IV(NGCOV) I = IV(1) IRC(NPROB) = RC(I) IS(6,NPROB) = JAC RS(1,NPROB) = X0SCAL RS(2,NPROB) = V(F) T = ONE IF (V(F0) .GT. ZERO) T = V(PREDUC) / V(F0) RS(3,NPROB) = T T = ONE IF (V(F0) .GT. ZERO) T = V(NREDUC) / V(F0) RS(4,NPROB) = T RS(5,NPROB) = V(RELDX) RSTRT = .FALSE. IF (NOUT .EQ. 0) GO TO 100 IF (NPROB .EQ. 1) WRITE(NOUT,50) DATIME 50 FORMAT(1H1,11X,2A4,2X,2A4,10X,24HNL2SOL TEST SUMMARY.....,10X, 1 32H(* = FINITE-DIFFERENCE JACOBIAN)/ 2 48H0 PROBLEM N P NITER NF NG IV1 X0SCAL,5X, 3 39HFINAL F PRELDF NRELDF RELDX/) WRITE(NOUT,60) JTYP(JAC), TITLE1, TITLE2, 1 (IS(I,NPROB),I=1,5),IRC(NPROB),(RS(I,NPROB),I=1,5) 60 FORMAT(1X,A1,2A4,2I4,I7,2I5,3X,A1,F9.1,E13.3,3E11.3) 100 CONTINUE C 999 RETURN C *** LAST CARD OF NLTEST FOLLOWS *** END SUBROUTINE TESTJ(N, P, X, NFCALL, J, UIPARM, URPARM, UFPARM) TSJ00010 C C *** PARAMETERS *** C INTEGER N, P, NFCALL, UIPARM(1) REAL X(P), J(N,P), URPARM(1) EXTERNAL UFPARM C C .................................................................. C .................................................................. C C *****PURPOSE. C THIS ROUTINE EVALUATES THE JACOBIAN MATRIX J FOR THE VARIOUS C TEST PROBLEMS LISTED IN REFERENCES (1), (2), AND (3). C C *****PARAMETER DESCRIPTION. C ON INPUT. C C NN IS THE ROW DIMENSION OF J AS DECLARED IN THE CALLING C PROGRAM. C N IS THE ACTUAL NUMBER OF ROWS IN J AND IS THE LENGTH OF R. C P IS THE NUMBER OF PARAMETERS BEING ESTIMATED AND HENCE IS C THE LENGTH OF X. C X IS THE VECTOR OF PARAMETERS AT WHICH THE JACOBIAN MATRIX J C IS TO BE COMPUTED. C NFCALL IS THE INVOCATION COUNT OF TESTR AT THE TIME WHEN R C WAS EVALUATED AT X. TESTR IGNORES NFCALL. C R IS THE RESIDUAL VECTOR AT X (AND IS IGNORED). C NEX = UIPARM(1) IS THE INDEX OF THE PROBLEM CURRENTLY BEING C SOLVED. C URPARM IS A USER PARAMETER VECTOR (AND IS IGNORED). C UFPARM IS A USER ENTRY POINT PARAMETER (AND IS IGNORED). C TESTR IS THE SUBROUTINE THAT COMPUTES R (AND IS IGNORED). C C ON OUTPUT. C C J IS THE JACOBIAN MATRIX AT X. C C *****APPLICATION AND USAGE RESTRICTIONS. C THESE TEST PROBLEMS MAY BE USED TO TEST LEAST-SQUARES SOLVERS C SUCH AS NL2SOL. IN PARTICULAR, THESE PROBLEMS MAY BE USED TO C CHECK WHETHER NL2SOL HAS BEEN SUCCESSFULLY TRANSPORTED TO C A PARTICULAR MACHINE. C C *****ALGORITHM NOTES. C NONE C C *****SUBROUTINES AND FUNCTIONS CALLED. C NONE C C *****REFERENCES C (1) GILL, P.E.; & MURRAY, W. (1976), ALGORITHMS FOR THE SOLUTION C OF THE NON-LINEAR LEAST-SQUARES PROBLEM, NPL REPORT NAC71. C C (2) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS C OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING, C EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER, C ACADEMIC PRESS, NEW YORK. C C (3) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON- C LIKE METHOD BASED UPON GAUSSIAN ELIMINATION, C SIAM J. NUMER. ANAL. 6, PP. 560-569. C C *****GENERAL. C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C .................................................................. C .................................................................. C C *** LOCAL VARIABLES AND CONSTANTS *** C REAL E, EXPMIN, R2, T, THETA, TI, TIM1, TIP1, TPI, 1 TPIM1, TPIP1, TWOPI, U, UFTOLG, UKOW(11), V, W, Z, ZERO INTEGER I, K, NEX, NM1 C *** INTRINSIC FUNCTIONS *** C/+ REAL ALOG, AMIN1, COS, EXP, FLOAT, SIN, SQRT C/ EXTERNAL RMDCON REAL RMDCON C C/6 C /6 DATA TWOPI/6.283185E+0/, ZERO/0.E+0/ C /7 C PARAMETER (TWOPI=6.283185E+0, ZERO=0.E+0) C / C/6 C/7 C SAVE EXPMIN, UFTOLG C/ DATA UKOW(1)/4.0/, UKOW(2)/2.0/, UKOW(3)/1.0/, 1 UKOW(4)/5.0E-1/, UKOW(5)/2.5E-1/, UKOW(6)/1.67E-1/, 2 UKOW(7)/1.25E-1/, UKOW(8)/1.0E-1/, UKOW(9)/8.33E-2/, 3 UKOW(10)/7.14E-2/, UKOW(11)/6.25E-2/ C *** MACHINE DEPENDENT CONSTANT *** DATA EXPMIN/0.0/, UFTOLG/0./ C C C----------------------------------------------------------------------- C NEX = UIPARM(1) GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100, 1 1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100, 2 2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100, 3 2500, 1300, 1400, 1500, 1600), NEX C C *** ROSENBROCK *** 100 J(1,1) = -2.0E1*X(1) J(1,2) = 1.0E1 J(2,1) = -1.0 J(2,2) = 0.0 GO TO 9999 C *** HELIX *** 200 T = X(1)**2 + X(2)**2 TI = 1.E2/(TWOPI*T) J(1,1) = TI*X(2) T = 1.E1/SQRT(T) J(2,1) = X(1)*T J(3,1) = 0. J(1,2) = -TI*X(1) J(2,2) = X(2)*T J(3,2) = 0. J(1,3) = 1.E1 J(2,3) = 0. J(3,3) = 1. GO TO 9999 C *** SINGULAR *** 300 DO 301 K = 1,4 DO 301 I = 1,4 301 J(I,K) = 0. J(1,1) = 1. J(1,2) = 1.E1 J(2,3) = SQRT(5.) J(2,4) = -J(2,3) J(3,2) = 2.*(X(2) - 2.*X(3)) J(3,3) = -2.*J(3,2) J(4,1) = SQRT(4.E1)*(X(1) - X(4)) J(4,4) = -J(4,1) GO TO 9999 C *** WOODS *** 400 DO 401 K = 1,4 DO 401 I = 1,7 401 J(I,K) = 0. J(1,1) = -2.E1*X(1) J(1,2) = 1.E1 J(2,1) = -1. J(3,4) = SQRT(9.E1) J(3,3) = -2.*X(3)*J(3,4) J(4,3) = -1. J(5,2) = SQRT(9.9) J(5,4) = J(5,2) J(6,2) = SQRT(0.2) J(7,4) = J(6,2) GO TO 9999 C *** ZANGWILL *** 500 DO 501 K = 1,3 DO 501 I = 1,3 501 J(I,K) = 1. J(1,2) = -1. J(2,1) = -1. J(3,3) = -1. GO TO 9999 C *** ENGVALL *** 600 J(1,1) = 2.*X(1) J(1,2) = 2.*X(2) J(1,3) = 2.*X(3) J(2,1) = J(1,1) J(2,2) = J(1,2) J(2,3) = 2.*(X(3) - 2.) J(3,1) = 1. J(3,2) = 1. J(3,3) = 1. J(4,1) = 1. J(4,2) = 1. J(4,3) = -1. T = 2.*(5.*X(3) - X(1) + 1.) J(5,1) = 3.*X(1)**2 - T J(5,2) = 6.*X(2) J(5,3) = 5.*T GO TO 9999 C *** BRANIN *** 700 J(1,1) = 4. J(1,2) = 4. J(2,1) = 3. + (X(1) - 2.)*(3.*X(1) - 2.*X(2) - 2.) + 1 X(2)*X(2) J(2,2) = 1. + 2.*(2.*X(1) - X(2)*X(2)) - (X(1) - X(2))**2 GO TO 9999 C *** BEALE *** 800 J(1,1) = X(2) - 1. J(1,2) = X(1) J(2,1) = X(2)**2 - 1. J(2,2) = 2.*X(1)*X(2) J(3,1) = X(2)**3 - 1. J(3,2) = 3.*X(1)*(X(2)**2) GO TO 9999 C *** CRAGG & LEVY *** 900 DO 901 I = 1,5 DO 901 K = 1,4 901 J(I,K) = 0. T = EXP(X(1)) J(1,2) = -2.*(T - X(2)) J(1,1) = -T * J(1,2) J(2,2) = 3.0E1*(X(2) - X(3))**2 J(2,3) = -J(2,2) J(3,3) = 2.*SIN(X(3) - X(4))/(COS(X(3) - X(4)))**3 J(3,4) = -J(3,3) J(4,1) = 4.*X(1)**3 J(5,4) = 1. GO TO 9999 C *** BOX *** 1000 IF (EXPMIN .EQ. ZERO) EXPMIN = 1.999*ALOG(RMDCON(2)) DO 1001 I = 1,10 TI = -0.1*FLOAT(I) E = ZERO T = X(1)*TI IF (T .GE. EXPMIN) E = EXP(T) J(I,1) = TI*E E = ZERO T = X(2)*TI IF (T .GE. EXPMIN) E = EXP(T) J(I,2) = -TI*E J(I,3) = EXP(1.E1*TI) - EXP(TI) 1001 CONTINUE GO TO 9999 C *** DAVIDON 1 *** 1100 NM1 = N-1 DO 1101 I = 1,NM1 TI = FLOAT(I) T = 1. DO 1101 K = 1,P J(I,K) = T T = T*TI 1101 CONTINUE J(N,1) = 1. DO 1102 K = 2,P 1102 J(N,K) = 0. GO TO 9999 C *** FREUDENSTEIN & ROTH *** 1200 J(1,1) = 1. J(1,2) = -2. + X(2)*(1.E1 - 3.*X(2)) J(2,1) = 1. J(2,2) = -1.4E1 + X(2)*(2. + 3.*X(2)) GO TO 9999 C *** WATSON *** 1300 CONTINUE 1400 CONTINUE 1500 CONTINUE 1600 DO 1603 I = 1,29 TI = FLOAT(I)/2.9E1 R2 = X(1) T= 1. DO 1601 K = 2,P T = T*TI R2 = R2 + T*X(K) 1601 CONTINUE R2 = -2.*R2 J(I,1) = R2 T = 1. R2 = TI*R2 DO 1602 K = 2,P J(I,K) = T*(FLOAT(K-1) + R2) T = T*TI 1602 CONTINUE 1603 CONTINUE DO 1604 I = 30,31 DO 1604 K = 2,P 1604 J(I,K) = 0. J(30,1) = 1. J(31,1) = -2.*X(1) J(31,2) = 1. GO TO 9999 C *** CHEBYQUAD *** 1700 DO 1701 K = 1,N TIM1 = -1./FLOAT(N) Z = 2.*X(K) - 1. TI = Z*TIM1 TPIM1 = 0. TPI = 2.*TIM1 Z = Z + Z DO 1701 I = 1,N J(I,K) = TPI TPIP1 = 4.*TI + Z*TPI - TPIM1 TPIM1 = TPI TPI = TPIP1 TIP1 = Z*TI - TIM1 TIM1 = TI TI = TIP1 1701 CONTINUE GO TO 9999 C *** BROWN AND DENNIS *** 1800 DO 1801 I = 1, N TI = 0.2*FLOAT(I) J(I,1) = 2.0*(X(1) + X(2)*TI - EXP(TI)) J(I,2) = TI*J(I,1) T = SIN(TI) J(I,3) = 2.0*(X(3) + X(4)*T - COS(TI)) J(I,4) = T*J(I,3) 1801 CONTINUE GO TO 9999 C *** BARD *** 1900 DO 1901 I = 1,15 J(I,1) = -1. U = FLOAT(I) V = 1.6E1 - U W = AMIN1 (U,V) T = U/(X(2)*V + X(3)*W)**2 J(I,2) = V*T J(I,3) = W*T 1901 CONTINUE GO TO 9999 C *** JENNRICH & SAMPSON *** 2000 DO 2001 I = 1,10 TI = FLOAT(I) J(I,1) = -TI*EXP(TI*X(1)) J(I,2) = -TI*EXP(TI*X(2)) 2001 CONTINUE GO TO 9999 C *** KOWALIK & OSBORNE *** 2100 DO 2101 I = 1,11 T = -1./(UKOW(I)**2 + X(3)*UKOW(I) + X(4)) J(I,1) = T*(UKOW(I)**2 + X(2)*UKOW(I)) J(I,2) = X(1)*UKOW(I)*T T = T*J(I,1)*X(1) J(I,3) = UKOW(I)*T J(I,4) = T 2101 CONTINUE GO TO 9999 C *** OSBORNE 1 *** 2200 DO 2201 I = 1,33 TI = 1.0E1*FLOAT(1-I) J(I,1) = -1. J(I,2) = -EXP(X(4)*TI) J(I,3) = -EXP(X(5)*TI) J(I,4) = TI*X(2)*J(I,2) J(I,5) = TI*X(3)*J(I,3) 2201 CONTINUE GO TO 9999 C *** OSBORNE 2 *** C *** UFTOLG IS A MACHINE-DEPENDENT CONSTANT. IT IS JUST SLIGHTLY C *** LARGER THAN THE LOG OF THE SMALLEST POSITIVE MACHINE NUMBER. 2300 IF (UFTOLG .EQ. 0.) UFTOLG = 1.999 * ALOG(RMDCON(2)) DO 2302 I = 1,65 TI = FLOAT(1 - I)*1.E-1 J(I,1) = -EXP(X(5)*TI) J(I,5) = X(1)*TI*J(I,1) DO 2301 K = 2,4 T = X(K + 7) + TI R2 = 0. THETA = -X(K+4)*T*T IF (THETA .GT. UFTOLG) R2 = -EXP(THETA) J(I,K) = R2 R2 = -T*R2*X(K) J(I,K+4) = R2*T J(I,K+7) = 2.*X(K+4)*R2 2301 CONTINUE 2302 CONTINUE GO TO 9999 C *** MADSEN *** 2400 J(1,1) = 2.*X(1) + X(2) J(1,2) = 2.*X(2) + X(1) J(2,1) = COS(X(1)) J(2,2) = 0. J(3,1) = 0. J(3,2) = -SIN(X(2)) GO TO 9999 C *** MEYER *** 2500 DO 2501 I = 1, 16 TI = FLOAT(5*I + 45) U = TI + X(3) T = EXP(X(2)/U) J(I,1) = T J(I,2) = X(1)*T/U J(I,3) = -X(1)*X(2)*T/(U*U) 2501 CONTINUE GO TO 9999 C *** BROWN *** 2600 CONTINUE 2700 CONTINUE 2800 CONTINUE 2900 NM1 = N - 1 DO 2901 K = 1, N DO 2901 I = 1, NM1 J(I,K) = 1.0 IF (I .EQ. K) J(I,K) = 2.0 2901 CONTINUE DO 2903 K = 1, N T = 1.0 DO 2902 I = 1,N IF (I .NE. K) T = T*X(I) 2902 CONTINUE J(N,K) = T 2903 CONTINUE GO TO 9999 C C 9999 RETURN END SUBROUTINE TESTR(N, P, X, NFCALL, R, UIPARM, URPARM, UFPARM) TES00010 C C *****PARAMETERS. C INTEGER N, P, NFCALL, UIPARM(1) REAL X(P), R(N), URPARM(1) EXTERNAL UFPARM C C .................................................................. C .................................................................. C C *****PURPOSE. C THIS ROUTINE EVALUATES R FOR THE VARIOUS TEST FUNCTIONS IN C REFERENCES (1), (2), AND (3), AS WELL AS FOR SOME VARIATIONS C SUGGESTED BY JORGE MORE (PRIVATE COMMUNICATION) ON SOME OF C THESE TEST PROBLEMS (FOR NEX .GE. 30). C C *****PARAMETER DESCRIPTION. C ON INPUT. C C N IS THE LENGTH OF R. C P IS THE LENGTH OF X. C X IS THE POINT AT WHICH THE RESIDUAL VECTOR R IS TO BE C COMPUTED. C NFCALL IS THE INVOCATION COUNT OF TESTR. C NEX = UIPARM(1) IS THE INDEX OF THE PROBLEM CURRENTLY BEING C SOLVED. C URPARM IS A USER PARAMETER VECTOR (AND IS IGNORED). C UFPARM IS A USER ENTRY POINT PARAMETER (AND IS IGNORED). C C ON OUTPUT. C C R IS THE RESIDUAL VECTOR AT X. C C *****APPLICATION AND USAGE RESTRICTIONS. C THESE TEST PROBLEMS MAY BE USED TO TEST LEAST-SQUARES SOLVERS C SUCH AS NL2SOL. IN PARTICULAR, THESE PROBLEMS MAY BE USED TO C CHECK WHETHER NL2SOL HAS BEEN SUCCESSFULLY TRANSPORTED TO C A PARTICULAR MACHINE. C C *****ALGORITHM NOTES. C NONE C C *****SUBROUTINES AND FUNCTIONS CALLED. C NONE C C *****REFERENCES C (1) GILL, P.E.. & MURRAY, W. (1976), ALGORITHMS FOR THE SOLUTION C OF THE NON-LINEAR LEAST-SQUARES PROBLEM, NPL REPORT NAC71. C C (2) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS C OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING, C EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER, C ACADEMIC PRESS, NEW YORK. C C (3) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON- C LIKE METHOD BASED UPON GAUSSIAN ELIMINATION, C SIAM J. NUMER. ANAL. 6, PP. 560-569. C C *****GENERAL. C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C .................................................................. C .................................................................. C C *** LOCAL VARIABLES AND CONSTANTS *** C REAL E1, E2, FLOATN, RI, R1, R2, T, THETA, TI, TIM1, 1 TIP1, TWOPI, T1, T2, U, V, W, Z REAL YBARD(15), YKOW(11), UKOW(11), YOSB1(33), 1 YOSB2(65), YMEYER(16) INTEGER I, J, NEX, NM1 REAL EXPMAX, EXPMIN, UFTOLG C *** INTRINSIC FUNCTIONS *** C/+ INTEGER MOD REAL ALOG, AMIN1, ATAN2, COS, EXP, FLOAT, SIN, SQRT C/ EXTERNAL RMDCON REAL RMDCON C /6 DATA TWOPI/6.283185E+0/ C /7 C PARAMETER (TWOPI=6.283185E+0) C / C/6 C/7 C SAVE EXPMAX, EXPMIN, UFTOLG C/ DATA YBARD(1)/1.4E-1/, YBARD(2)/1.8E-1/, YBARD(3)/2.2E-1/, 1 YBARD(4)/2.5E-1/, YBARD(5)/2.9E-1/, YBARD(6)/3.2E-1/, 2 YBARD(7)/3.5E-1/, YBARD(8)/3.9E-1/, YBARD(9)/3.7E-1/, 3 YBARD(10)/5.8E-1/, YBARD(11)/7.3E-1/, YBARD(12)/9.6E-1/, 4 YBARD(13)/1.34/, YBARD(14)/2.10/, YBARD(15)/4.39/ DATA YKOW(1)/1.957E-1/, YKOW(2)/1.947E-1/, YKOW(3)/1.735E-1/, 1 YKOW(4)/1.600E-1/, YKOW(5)/8.44E-2/, YKOW(6)/6.27E-2/, 2 YKOW(7)/4.56E-2/, YKOW(8)/3.42E-2/, YKOW(9)/3.23E-2/, 3 YKOW(10)/2.35E-2/, YKOW(11)/2.46E-2/ DATA UKOW(1)/4.0/, UKOW(2)/2.0/, UKOW(3)/1.0/, 1 UKOW(4)/5.0E-1/, UKOW(5)/2.5E-1/, UKOW(6)/1.67E-1/, 2 UKOW(7)/1.25E-1/, UKOW(8)/1.0E-1/, UKOW(9)/8.33E-2/, 3 UKOW(10)/7.14E-2/, UKOW(11)/6.25E-2/ DATA YOSB1(1)/8.44E-1/, YOSB1(2)/9.08E-1/, YOSB1(3)/9.32E-1/, 1 YOSB1(4)/9.36E-1/, YOSB1(5)/9.25E-1/, YOSB1(6)/9.08E-1/, 2 YOSB1(7)/8.81E-1/, YOSB1(8)/8.50E-1/, YOSB1(9)/8.18E-1/, 3 YOSB1(10)/7.84E-1/, YOSB1(11)/7.51E-1/, YOSB1(12)/7.18E-1/, 4 YOSB1(13)/6.85E-1/, YOSB1(14)/6.58E-1/, YOSB1(15)/6.28E-1/, 5 YOSB1(16)/6.03E-1/, YOSB1(17)/5.80E-1/, YOSB1(18)/5.58E-1/, 6 YOSB1(19)/5.38E-1/, YOSB1(20)/5.22E-1/, YOSB1(21)/5.06E-1/, 7 YOSB1(22)/4.90E-1/, YOSB1(23)/4.78E-1/, YOSB1(24)/4.67E-1/, 8 YOSB1(25)/4.57E-1/, YOSB1(26)/4.48E-1/, YOSB1(27)/4.38E-1/, 9 YOSB1(28)/4.31E-1/, YOSB1(29)/4.24E-1/, YOSB1(30)/4.20E-1/, A YOSB1(31)/4.14E-1/, YOSB1(32)/4.11E-1/, YOSB1(33)/4.06E-1/ DATA YOSB2(1)/1.366/, YOSB2(2)/1.191/, YOSB2(3)/1.112/, 1 YOSB2(4)/1.013/, YOSB2(5)/9.91E-1/, YOSB2(6)/8.85E-1/, 2 YOSB2(7)/8.31E-1/, YOSB2(8)/8.47E-1/, YOSB2(9)/7.86E-1/, 3 YOSB2(10)/7.25E-1/, YOSB2(11)/7.46E-1/, YOSB2(12)/6.79E-1/, 4 YOSB2(13)/6.08E-1/, YOSB2(14)/6.55E-1/, YOSB2(15)/6.16E-1/, 5 YOSB2(16)/6.06E-1/, YOSB2(17)/6.02E-1/, YOSB2(18)/6.26E-1/, 6 YOSB2(19)/6.51E-1/, YOSB2(20)/7.24E-1/, YOSB2(21)/6.49E-1/, 7 YOSB2(22)/6.49E-1/, YOSB2(23)/6.94E-1/, YOSB2(24)/6.44E-1/, 8 YOSB2(25)/6.24E-1/, YOSB2(26)/6.61E-1/, YOSB2(27)/6.12E-1/, 9 YOSB2(28)/5.58E-1/, YOSB2(29)/5.33E-1/, YOSB2(30)/4.95E-1/, A YOSB2(31)/5.00E-1/, YOSB2(32)/4.23E-1/, YOSB2(33)/3.95E-1/, B YOSB2(34)/3.75E-1/, YOSB2(35)/3.72E-1/, YOSB2(36)/3.91E-1/, C YOSB2(37)/3.96E-1/, YOSB2(38)/4.05E-1/, YOSB2(39)/4.28E-1/, D YOSB2(40)/4.29E-1/, YOSB2(41)/5.23E-1/, YOSB2(42)/5.62E-1/, E YOSB2(43)/6.07E-1/, YOSB2(44)/6.53E-1/, YOSB2(45)/6.72E-1/, F YOSB2(46)/7.08E-1/, YOSB2(47)/6.33E-1/, YOSB2(48)/6.68E-1/, G YOSB2(49)/6.45E-1/, YOSB2(50)/6.32E-1/, YOSB2(51)/5.91E-1/, H YOSB2(52)/5.59E-1/, YOSB2(53)/5.97E-1/, YOSB2(54)/6.25E-1/, I YOSB2(55)/7.39E-1/, YOSB2(56)/7.10E-1/, YOSB2(57)/7.29E-1/, J YOSB2(58)/7.20E-1/, YOSB2(59)/6.36E-1/, YOSB2(60)/5.81E-1/ DATA YOSB2(61)/4.28E-1/, YOSB2(62)/2.92E-1/, YOSB2(63)/1.62E-1/, 1 YOSB2(64)/9.8E-2/, YOSB2(65)/5.4E-2/ DATA YMEYER(1)/3.478E4/, YMEYER(2)/2.861E4/, YMEYER(3)/2.365E4/, 1 YMEYER(4)/1.963E4/, YMEYER(5)/1.637E4/, YMEYER(6)/1.372E4/, 2 YMEYER(7)/1.154E4/, YMEYER(8)/9.744E3/, YMEYER(9)/8.261E3/, 3 YMEYER(10)/7.030E3/, YMEYER(11)/6.005E3/, YMEYER(12)/5.147E3/, 4 YMEYER(13)/4.427E3/, YMEYER(14)/3.820E3/, YMEYER(15)/3.307E3/, 5 YMEYER(16)/2.872E3/ C DATA EXPMAX/0./, UFTOLG/0./ C C C----------------------------------------------------------------------- C NEX = UIPARM(1) GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100, 1 1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100, 2 2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100, 3 2500, 1300, 1400, 1500, 1600), NEX C C *** ROSENBROCK *** 100 R(1) = 1.0E1*(X(2) - X(1)**2) R(2) = 1.0 - X(1) GO TO 9999 C *** HELIX *** 200 THETA = ATAN2(X(2), X(1))/TWOPI IF (X(1) .LE. 0. .AND. X(2) .LE. 0.) THETA = THETA + 1. R(1) = 1.0E1*(X(3) - 1.0E1*THETA) R(2) = 1.0E1*(SQRT(X(1)**2 + X(2)**2) - 1.0) R(3) = X(3) GO TO 9999 C *** SINGULAR *** 300 R(1) = X(1) + 1.0E1*X(2) R(2) = SQRT(5.0)*(X(3) - X(4)) R(3) = (X(2) - 2.0*X(3))**2 R(4) = SQRT(1.0E1)*(X(1) - X(4))**2 GO TO 9999 C *** WOODS *** 400 R(1) = 1.0E1*(X(2) - X(1)**2) R(2) = 1.0 - X(1) R(3) = SQRT(9.0E1)*(X(4) - X(3)**2) R(4) = 1.0 - X(3) R(5) = SQRT(9.9)*(X(2) + X(4) - 2.) T = SQRT(2.0E-1) R(6) = T*(X(2) - 1.0) R(7) = T*(X(4) - 1.0) GO TO 9999 C *** ZANGWILL 500 R(1) = X(1) - X(2) + X(3) R(2) = -X(1) + X(2) + X(3) R(3) = X(1) + X(2) - X(3) GO TO 9999 C *** ENGVALL *** 600 R(1) = X(1)**2 + X(2)**2 + X(3)**2 - 1.0 R(2) = X(1)**2 + X(2)**2 + (X(3) - 2.0)**2 - 1.0 R(3) = X(1) + X(2) + X(3) - 1.0 R(4) = X(1) + X(2) - X(3) + 1.0 R(5) = X(1)**3 + 3.0*X(2)**2 + (5.0*X(3) - X(1) + 1.0)**2 1 - 3.6E1 GO TO 9999 C *** BRANIN *** 700 R(1) = 4.0*(X(1) + X(2)) R(2) = R(1) + (X(1) - X(2))*((X(1) - 2.0)**2 + 1 X(2)**2 - 1.0) GO TO 9999 C *** BEALE *** 800 R(1) = 1.5 - X(1)*(1.0 - X(2)) R(2) = 2.25 - X(1)*(1.0 - X(2)**2) R(3) = 2.625 - X(1)*(1.0 - X(2)**3) GO TO 9999 C *** CRAGG AND LEVY *** 900 R(1) = (EXP(X(1)) - X(2))**2 R(2) = 1.0E1*(X(2) - X(3))**3 R(3) = ( SIN(X(3) - X(4)) / COS(X(3) - X(4)) )**2 R(4) = X(1)**4 R(5) = X(4) - 1.0 GO TO 9999 C *** BOX *** 1000 IF (EXPMAX .GT. 0.) GO TO 1001 EXPMAX = 1.999 * ALOG(RMDCON(5)) EXPMIN = 1.999 * ALOG(RMDCON(2)) 1001 IF (-EXPMAX .GE. AMIN1(X(1), X(2), X(3))) GO TO 1003 DO 1002 I = 1,10 TI = -0.1*FLOAT(I) T1 = TI*X(1) E1 = 0. IF (T1 .GT. EXPMIN) E1 = EXP(T1) T2 = TI*X(2) E2 = 0. IF (T2 .GT. EXPMIN) E2 = EXP(T2) R(I) = (E1 - E2) - X(3)*(EXP(TI) - EXP(1.0E1*TI)) 1002 CONTINUE GO TO 9999 1003 NFCALL = -1 GO TO 9999 C *** DAVIDON 1 *** 1100 NM1 = N - 1 DO 1102 I = 1, NM1 R1 = 0.0 TI = FLOAT(I) T = 1. DO 1101 J = 1,P R1 = R1 + T*X(J) T = T*TI 1101 CONTINUE R(I) = R1 1102 CONTINUE R(N) = X(1) - 1.0 GO TO 9999 C *** FREUDENSTEIN AND ROTH *** 1200 R(1) = -1.3E1 + X(1) - 2.0*X(2) + 5.0*X(2)**2 - X(2)**3 R(2) = -2.9E1 + X(1) - 1.4E1*X(2) + X(2)**2 + X(2)**3 GO TO 9999 C *** WATSON *** 1300 CONTINUE 1400 CONTINUE 1500 CONTINUE 1600 DO 1602 I = 1, 29 TI = FLOAT(I)/2.9E1 R1 = 0.0 R2 = X(1) T = 1.0 DO 1601 J = 2, P R1 = R1 + FLOAT(J-1)*T*X(J) T = T*TI R2 = R2 + T*X(J) 1601 CONTINUE R(I) = R1 - R2*R2 - 1.0 IF (NEX .GE. 33 .AND. NEX .LE. 36) R(I) = R(I) + 10. 1602 CONTINUE R(30) = X(1) R(31) = X(2) - X(1)**2 - 1.0 IF (NEX .LT. 33 .OR. NEX .GT. 36) GO TO 9999 R(30) = R(30) + 10. R(31) = R(31) + 10. GO TO 9999 C *** CHEBYQUAD *** 1700 DO 1701 I = 1,N 1701 R(I) = 0.0 DO 1702 J = 1,N TIM1 = 1.0 TI = 2.0*X(J) - 1.0 Z = TI + TI DO 1702 I = 1,N R(I) = R(I) + TI TIP1 = Z*TI -TIM1 TIM1 = TI TI = TIP1 1702 CONTINUE FLOATN = FLOAT(N) DO 1703 I = 1,N TI = 0.0 IF (MOD(I,2) .EQ. 0) TI = -1.0/FLOAT(I*I - 1) R(I) = TI - R(I)/FLOATN 1703 CONTINUE GO TO 9999 C *** BROWN AND DENNIS *** 1800 DO 1801 I = 1, N TI = 0.2*FLOAT(I) R(I) = (X(1) + X(2)*TI - EXP(TI))**2 + 1 (X(3) + X(4)*SIN(TI) - COS(TI))**2 1801 CONTINUE GO TO 9999 C *** BARD *** 1900 DO 1901 I = 1, 15 U = FLOAT(I) V = 1.6E1 - U W = AMIN1(U,V) R(I) = YBARD(I) - (X(1) + U/(X(2)*V + X(3)*W)) IF (NEX .EQ. 30) R(I) = R(I) + 10. 1901 CONTINUE GO TO 9999 C *** JENNRICH AND SAMPSON *** 2000 DO 2001 I = 1, 10 TI = FLOAT(I) R(I) = 2.0 + 2.0*TI - (EXP(TI*X(1)) + 1 EXP(TI*X(2))) 2001 CONTINUE GO TO 9999 C *** KOWALIK AND OSBORNE *** 2100 DO 2101 I = 1, 11 R(I) = YKOW(I) - X(1)*(UKOW(I)**2 + X(2)*UKOW(I))/(UKOW(I)**2 + 1 X(3)*UKOW(I) + X(4)) IF (NEX .EQ. 31) R(I) = R(I) + 10. 2101 CONTINUE GO TO 9999 C *** OSBORNE 1 *** 2200 DO 2201 I = 1, 33 TI = 1.0E1*FLOAT(1-I) R(I) = YOSB1(I) - (X(1) + X(2)*EXP(X(4)*TI) + 1 X(3)*EXP(X(5)*TI)) 2201 CONTINUE GO TO 9999 C *** OSBORNE 2 *** C *** UFTOLG IS A MACHINE-DEPENDENT CONSTANT. IT IS JUST SLIGHTLY C *** LARGER THAN THE LOG OF THE SMALLEST POSITIVE MACHINE NUMBER. 2300 IF (UFTOLG .EQ. 0.) UFTOLG = 1.999 * ALOG(RMDCON(2)) DO 2302 I = 1, 65 TI = 0.1*FLOAT(1-I) RI = X(1)*EXP(X(5)*TI) DO 2301 J = 2, 4 T = 0. THETA = -X(J+4) * (TI + X(J+7))**2 IF (THETA .GT. UFTOLG) T = EXP(THETA) RI = RI + X(J)*T 2301 CONTINUE R(I) = YOSB2(I) - RI 2302 CONTINUE GO TO 9999 C *** MADSEN *** 2400 R(1) = X(1)**2 + X(2)**2 + X(1)*X(2) R(2) = SIN(X(1)) R(3) = COS(X(2)) GO TO 9999 C *** MEYER *** 2500 DO 2501 I = 1, 16 TI = FLOAT(5*I + 45) R(I)=X(1)*EXP(X(2)/(TI + X(3))) - YMEYER(I) IF (NEX .EQ. 32) R(I) = R(I) + 10. 2501 CONTINUE GO TO 9999 C *** BROWN *** 2600 CONTINUE 2700 CONTINUE 2800 CONTINUE 2900 T = X(1) - FLOAT(N + 1) DO 2901 I = 2, N 2901 T = T + X(I) NM1 = N - 1 DO 2902 I = 1, NM1 2902 R(I) = T + X(I) T = X(1) DO 2903 I = 2, N 2903 T = T * X(I) R(N) = T - 1.0 GO TO 9999 C 9999 RETURN C ..... LAST CARD OF TESTR ......................................... END SUBROUTINE TODAY(DATIME) TOD00010 C C *** SUPPLY SUMSOL VERSION *** C C/6 REAL DATIME(4), DT1, DT2, DT3, DT4 DATA DT1,DT2,DT3,DT4/4HNL2S,4HOL ,4HVER.,4H2.2 / C/7 C CHARACTER*4 DATIME(4), DT1, DT2, DT3, DT4 C DATA DT1,DT2,DT3,DT4/'NL2S','OL ','VER.','2.2 '/ C/ C DATIME(1) = DT1 DATIME(2) = DT2 DATIME(3) = DT3 DATIME(4) = DT4 999 RETURN C *** LAST LINE OF DATIME FOLLOWS *** END SUBROUTINE XINIT(P, X, NEX) XIN00010 C C *****PARAMETERS... C INTEGER NEX, P REAL X(P) C C .................................................................. C C *****PURPOSE... C THIS ROUTINE INITIALIZES THE SOLUTION VECTOR X ACCORDING TO C THE INITIAL VALUES FOR THE VARIOUS TEST FUNCTIONS GIVEN IN C REFERENCES (1), (2), AND (3). C SUBROUTINES TESTR AND TESTJ. (SEE TESTR FOR REFERENCES.) C C *****PARAMETER DESCRIPTION... C ON INPUT... C C NEX IS THE TEST PROBLEM NUMBER. C C P IS THE NUMBER OF PARAMETERS. C C ON OUTPUT... C C X IS THE INITIAL GUESS TO THE SOLUTION. C C *****APPLICATION AND USAGE RESTRICTIONS... C THIS ROUTINE IS CALLED BY NLTEST. C C .................................................................. C C *****LOCAL VARIABLES... INTEGER I REAL PP1INV C *****INTRINSIC FUNCTIONS... C/+ REAL FLOAT C/ C GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100, 1 1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100, 2 2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100, 3 2500, 1300, 1400, 1500, 1600),NEX C C *** ROSENBROCK *** 100 X(1) = -1.2 X(2) = 1.0 GO TO 9999 C *** HELIX *** 200 X(1) = -1.0 X(2) = 0.0 X(3) = 0.0 GO TO 9999 C *** SINGULAR *** 300 X(1) = 3.0 X(2) = -1.0 X(3) = 0.0 X(4) = 1.0 GO TO 9999 C *** WOODS *** 400 X(1) = -3.0 X(2) = -1.0 X(3) = -3.0 X(4) = -1.0 GO TO 9999 C *** ZANGWILL *** 500 X(1) = 1.0E2 X(2) = -1.0 X(3) = 2.5 GO TO 9999 C *** ENGVALL *** 600 X(1) = 1.0 X(2) = 2.0 X(3) = 0.0 GO TO 9999 C *** BRANIN *** 700 X(1) = 2.0 X(2) = 0.0 GO TO 9999 C *** BEALE *** 800 X(1) = 1.0E-1 X(2) = 1.0E-1 GO TO 9999 C *** CRAGG AND LEVY *** 900 X(1) = 1.0 X(2) = 2.0 X(3) = 2.0 X(4) = 2.0 GO TO 9999 C *** BOX *** 1000 X(1) = 0.0 X(2) = 1.0E1 X(3) = 2.0E1 GO TO 9999 C *** DAVIDON 1 *** 1100 DO 1101 I = 1,P 1101 X(I) = 0.0 GO TO 9999 C *** FREUDENSTEIN AND ROTH *** 1200 X(1) = 1.5E1 X(2) = -2.0 GO TO 9999 C *** WATSON *** 1300 CONTINUE 1400 CONTINUE 1500 CONTINUE 1600 DO 1601 I = 1,P 1601 X(I) = 0.0 GO TO 9999 C *** CHEBYQUAD *** 1700 PP1INV = 1.0/FLOAT(P + 1) DO 1701 I = 1, P 1701 X(I) = FLOAT(I)*PP1INV GO TO 9999 C *** BROWN AND DENNIS *** 1800 X(1) = 2.5E1 X(2) = 5.0 X(3) = -5.0 X(4) = -1.0 GO TO 9999 C *** BARD *** 1900 X(1) = 1. X(2) = 1. X(3) = 1. GO TO 9999 C *** JENNRICH AND SAMPSON *** 2000 X(1) = 3.0E-1 X(2) = 4.0E-1 GO TO 9999 C *** KOWALIK AND OSBORNE *** 2100 X(1) = 2.5E-1 X(2) = 3.9E-1 X(3) = 4.15E-1 X(4) = 3.9E-1 GO TO 9999 C *** OSBORNE 1 *** 2200 X(1) = 5.0E-1 X(2) = 1.5 X(3) = -1.0 X(4) = 1.0E-2 X(5) = 2.0E-2 GO TO 9999 C *** OSBORNE 2 *** 2300 X(1) = 1.3 X(2) = 6.5E-1 X(3) = 6.5E-1 X(4) = 7.0E-1 X(5) = 6.0E-1 X(6) = 3.0 X(7) = 5.0 X(8) = 7.0 X(9) = 2.0 X(10) = 4.5 X(11) = 5.5 GO TO 9999 C *** MADSEN *** 2400 X(1) = 3.0 X(2) = 1.0 GO TO 9999 C *** MEYER ** 2500 X(1) = 2.0E-2 X(2) = 4.0E3 X(3) = 2.5E2 GO TO 9999 C *** BROWN *** 2600 CONTINUE 2700 CONTINUE 2800 CONTINUE 2900 DO 2901 I = 1, P 2901 X(I) = 5.E-1 GO TO 9999 C C 9999 RETURN END C/////////////////////////////////////////////////////////////////////// C *** TEST NL2SOL AND NL2SNO ON MADSEN EXAMPLE *** MAD00010 INTEGER IV(62), UIPARM(1) DOUBLE PRECISION V(147), X(2), URPARM(1) EXTERNAL MADR, MADJ X(1) = 3.0D0 X(2) = 1.0D0 IV(1) = 0 CALL NL2SOL(3, 2, X, MADR, MADJ, IV, V, UIPARM, URPARM, MADR) IV(1) = 12 X(1) = 3.0D0 X(2) = 1.0D0 CALL NL2SNO(3, 2, X, MADR, IV, V, UIPARM, URPARM, MADR) STOP END SUBROUTINE MADR(N, P, X, NF, R, UIPARM, URPARM, UFPARM) INTEGER N, P, NF, UIPARM(1) DOUBLE PRECISION X(P), R(N), URPARM(1) EXTERNAL UFPARM R(1) = X(1)**2 + X(2)**2 + X(1)*X(2) R(2) = DSIN(X(1)) R(3) = DCOS(X(2)) RETURN END SUBROUTINE MADJ(N, P, X, NF, J, UIPARM, URPARM, UFPARM) INTEGER N, P, NF, UIPARM(1) DOUBLE PRECISION X(P), J(N,P), URPARM(1) EXTERNAL UFPARM J(1,1) = 2.0D0*X(1) + X(2) J(1,2) = 2.0D0*X(2) + X(1) J(2,1) = DCOS(X(1)) J(2,2) = 0.0D0 J(3,1) = 0.0D0 J(3,2) = -DSIN(X(2)) RETURN END C/////////////////////////////////////////////////////////////////////// INTEGER FUNCTION IMDCON(K) IMD00010 C INTEGER K C C *** RETURN INTEGER MACHINE-DEPENDENT CONSTANTS *** C C *** K = 1 MEANS RETURN STANDARD OUTPUT UNIT NUMBER. *** C *** K = 2 MEANS RETURN ALTERNATE OUTPUT UNIT NUMBER. *** C *** K = 3 MEANS RETURN INPUT UNIT NUMBER. *** C (NOTE -- K = 2, 3 ARE USED ONLY BY TEST PROGRAMS.) C INTEGER MDCON(3) DATA MDCON(1)/6/, MDCON(2)/8/, MDCON(3)/5/ C IMDCON = MDCON(K) RETURN C *** LAST CARD OF IMDCON FOLLOWS *** END DOUBLE PRECISION FUNCTION RMDCON(K) RMD00010 C C *** RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL *** C C +++ COMMENTS BELOW CONTAIN DATA STATEMENTS FOR VARIOUS MACHINES. +++ C +++ TO CONVERT TO ANOTHER MACHINE, PLACE A C IN COLUMN 1 OF THE +++ C +++ DATA STATEMENT LINE(S) THAT CORRESPOND TO THE CURRENT MACHINE +++ C +++ AND REMOVE THE C FROM COLUMN 1 OF THE DATA STATEMENT LINE(S) +++ C +++ THAT CORRESPOND TO THE NEW MACHINE. +++ C INTEGER K C C *** THE CONSTANT RETURNED DEPENDS ON K... C C *** K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS. C *** K = 2... SQUARE ROOT OF 1.001*ETA. C *** K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH C *** THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1. C *** K = 4... SQUARE ROOT OF 0.999*MACHEP. C *** K = 5... SQUARE ROOT OF 0.999*BIG (SEE K = 6). C *** K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS. C DOUBLE PRECISION BIG, ETA, MACHEP C/+ DOUBLE PRECISION DSQRT C/ DOUBLE PRECISION ONE001, PT999 C DATA ONE001/1.001D0/, PT999/0.999D0/ C C +++ IBM 360, IBM 370, OR XEROX +++ C DATA BIG/Z7FFFFFFFFFFFFFFF/, ETA/Z0010000000000000/, 1 MACHEP/Z3410000000000000/ C C +++ DATA GENERAL +++ C C DATA BIG/0.7237005577D+76/, ETA/0.5397605347D-78/, C 1 MACHEP/2.22044605D-16/ C C +++ DEC 11 +++ C C DATA BIG/1.7D+38/, ETA/2.938735878D-39/, MACHEP/2.775557562D-17/ C C +++ HP3000 +++ C C DATA BIG/1.157920892D+77/, ETA/8.636168556D-78/, C 1 MACHEP/5.551115124D-17/ C C +++ HONEYWELL +++ C C DATA BIG/1.69D+38/, ETA/5.9D-39/, MACHEP/2.1680435D-19/ C C +++ DEC10 +++ C C DATA BIG/"377777100000000000000000/, C 1 ETA/"002400400000000000000000/, C 2 MACHEP/"104400000000000000000000/ C C +++ BURROUGHS +++ C C DATA BIG/O0777777777777777,O7777777777777777/, C 1 ETA/O1771000000000000,O7770000000000000/, C 2 MACHEP/O1451000000000000,O0000000000000000/ C C +++ CONTROL DATA +++ C C C DATA BIG/37767777777777777777B,37167777777777777777B/, C 1 ETA/00014000000000000000B,00000000000000000000B/, C 2 MACHEP/15614000000000000000B,15010000000000000000B/ C C +++ PRIME +++ C C DATA BIG/1.0D+9786/, ETA/1.0D-9860/, MACHEP/1.4210855D-14/ C C +++ UNIVAC +++ C C DATA BIG/8.988D+307/, ETA/1.2D-308/, MACHEP/1.734723476D-18/ C C +++ VAX +++ C C DATA BIG/1.7D+38/, ETA/2.939D-39/, MACHEP/1.3877788D-17/ C C------------------------------- BODY -------------------------------- C GO TO (10, 20, 30, 40, 50, 60), K C 10 RMDCON = ETA GO TO 999 C 20 RMDCON = DSQRT(ONE001*ETA) GO TO 999 C 30 RMDCON = MACHEP GO TO 999 C 40 RMDCON = DSQRT(PT999*MACHEP) GO TO 999 C 50 RMDCON = DSQRT(PT999*BIG) GO TO 999 C 60 RMDCON = BIG C 999 RETURN C *** LAST CARD OF RMDCON FOLLOWS *** END C/////////////////////////////////////////////////////////////////////// SUBROUTINE NL2SOL(N, P, X, CALCR, CALCJ, IV, V, UIPARM, URPARM, NL200010 1 UFPARM) C C *** MINIMIZE NONLINEAR SUM OF SQUARES USING ANALYTIC JACOBIAN *** C *** (NL2SOL VERSION 2.2) *** C INTEGER N, P, IV(1), UIPARM(1) DOUBLE PRECISION X(P), V(1), URPARM(1) C DIMENSION IV(60+P), V(93 + N*P + 3*N + P*(3*P+33)/2) C DIMENSION UIPARM(*), URPARM(*) EXTERNAL CALCR, CALCJ, UFPARM C C *** PURPOSE *** C C GIVEN A P-VECTOR X OF PARAMETERS, CALCR COMPUTES AN N-VECTOR C R = R(X) OF RESIDUALS CORRESPONDING TO X. (R(X) PROBABLY ARISES C FROM A NONLINEAR MODEL INVOLVING P PARAMETERS AND N OBSERVATIONS.) C THIS ROUTINE INTERACTS WITH NL2ITR TO SEEK A PARAMETER VECTOR X C THAT MINIMIZES THE SUM OF THE SQUARES OF (THE COMPONENTS OF) R(X), C I.E., THAT MINIMIZES THE SUM-OF-SQUARES FUNCTION C F(X) = (R(X)**T) * R(X) / 2. R(X) IS ASSUMED TO BE A TWICE CON- C TINUOUSLY DIFFERENTIABLE FUNCTION OF X. C C-------------------------- PARAMETER USAGE -------------------------- C C N........ (INPUT) THE NUMBER OF OBSERVATIONS, I.E., THE NUMBER OF C COMPONENTS IN R(X). N MUST BE .GE. P. C P........ (INPUT) THE NUMBER OF PARAMETERS (COMPONENTS IN X). P MUST C BE POSITIVE. C X........ (INPUT/OUTPUT). ON INPUT, X IS AN INITIAL GUESS AT THE C DESIRED PARAMETER ESTIMATE. ON OUTPUT, X CONTAINS C THE BEST PARAMETER ESTIMATE FOUND. C CALCR.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES R(X). CALCR C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. C IT IS INVOKED BY C CALL CALCR(N,P,X,NF,R,UIPARM,URPARM,UFPARM) C WHEN CALCR IS CALLED, NF IS THE INVOCATION COUNT C FOR CALCR. IT IS INCLUDED FOR POSSIBLE USE WITH C CALCJ. IF X IS OUT OF BOUNDS (E.G. IF IT WOULD C CAUSE OVERFLOW IN COMPUTING R(X)), THEN CALCR SHOULD C SET NF TO 0. THIS WILL CAUSE A SHORTER STEP TO BE C ATTEMPTED. THE OTHER PARAMETERS ARE AS DESCRIBED C ABOVE AND BELOW. CALCR SHOULD NOT CHANGE N, P, OR X. C CALCJ.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES THE JACOBIAN C MATRIX J OF R AT X, I.E., THE N BY P MATRIX WHOSE C (I,K) ENTRY IS THE PARTIAL DERIVATIVE OF THE I-TH C COMPONENT OF R WITH RESPECT TO X(K). CALCJ MUST BE C DECLARED EXTERNAL IN THE CALLING PROGRAM. IT IS C INVOKED BY C CALL CALCJ(N,P,X,NF,J,UIPARM,URPARM,UFPARM) C NF IS THE INVOCATION COUNT FOR CALCR AT THE TIME C R(X) WAS EVALUATED. THE X PASSED TO CALCJ IS C USUALLY THE ONE PASSED TO CALCR ON EITHER ITS MOST C RECENT INVOCATION OR THE ONE PRIOR TO IT. IF CALCR C SAVES INTERMEDIATE RESULTS FOR USE BY CALCJ, THEN IT C IS POSSIBLE TO TELL FROM NF WHETHER THEY ARE VALID C FOR THE CURRENT X (OR WHICH COPY IS VALID IF TWO C COPIES ARE KEPT). IF J CANNOT BE COMPUTED AT X, C THEN CALCJ SHOULD SET NF TO 0. IN THIS CASE, NL2SOL C WILL RETURN WITH IV(1) = 15. THE OTHER PARAMETERS C TO CALCJ ARE AS DESCRIBED ABOVE AND BELOW. CALCJ C SHOULD NOT CHANGE N, P, OR X. C IV....... (INPUT/OUTPUT) AN INTEGER VALUE ARRAY OF LENGTH AT LEAST C 60 + P THAT HELPS CONTROL THE NL2SOL ALGORITHM AND C THAT IS USED TO STORE VARIOUS INTERMEDIATE QUANTI- C TIES. OF PARTICULAR INTEREST ARE THE INITIALIZATION/ C RETURN CODE IV(1) AND THE ENTRIES IN IV THAT CONTROL C PRINTING AND LIMIT THE NUMBER OF ITERATIONS AND FUNC- C TION EVALUATIONS. SEE THE SECTION ON IV INPUT C VALUES BELOW. C V........ (INPUT/OUTPUT) A FLOATING-POINT VALUE ARRAY OF LENGTH AT C LEAST 93 + N*P + 3*N + P*(3*P+33)/2 THAT HELPS CON- C TROL THE NL2SOL ALGORITHM AND THAT IS USED TO STORE C VARIOUS INTERMEDIATE QUANTITIES. OF PARTICULAR IN- C TEREST ARE THE ENTRIES IN V THAT LIMIT THE LENGTH OF C THE FIRST STEP ATTEMPTED (LMAX0), SPECIFY CONVER- C GENCE TOLERANCES (AFCTOL, RFCTOL, XCTOL, XFTOL), C AND HELP CHOOSE THE STEP SIZE USED IN COMPUTING THE C COVARIANCE MATRIX (DELTA0). SEE THE SECTION ON C (SELECTED) V INPUT VALUES BELOW. C UIPARM... (INPUT) USER INTEGER PARAMETER ARRAY PASSED WITHOUT CHANGE C TO CALCR AND CALCJ. C URPARM... (INPUT) USER FLOATING-POINT PARAMETER ARRAY PASSED WITHOUT C CHANGE TO CALCR AND CALCJ. C UFPARM... (INPUT) USER EXTERNAL SUBROUTINE OR FUNCTION PASSED WITHOUT C CHANGE TO CALCR AND CALCJ. C C *** IV INPUT VALUES (FROM SUBROUTINE DFAULT) *** C C IV(1)... ON INPUT, IV(1) SHOULD HAVE A VALUE BETWEEN 0 AND 12...... C 0 AND 12 MEAN THIS IS A FRESH START. 0 MEANS THAT C DFAULT(IV, V) IS TO BE CALLED TO PROVIDE ALL DEFAULT C VALUES TO IV AND V. 12 (THE VALUE THAT DFAULT ASSIGNS TO C IV(1)) MEANS THE CALLER HAS ALREADY CALLED DFAULT(IV, V) C AND HAS POSSIBLY CHANGED SOME IV AND/OR V ENTRIES TO NON- C DEFAULT VALUES. DEFAULT = 12. C IV(COVPRT)... IV(14) = 1 MEANS PRINT A COVARIANCE MATRIX AT THE SOLU- C TION. (THIS MATRIX IS COMPUTED JUST BEFORE A RETURN WITH C IV(1) = 3, 4, 5, 6.) C IV(COVPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(COVREQ)... IV(15) = NONZERO MEANS COMPUTE A COVARIANCE MATRIX C JUST BEFORE A RETURN WITH IV(1) = 3, 4, 5, 6. IN C THIS CASE, AN APPROXIMATE COVARIANCE MATRIX IS OBTAINED C IN ONE OF SEVERAL WAYS. LET K = ABS(IV(COVREQ)) AND LET C SCALE = 2*F(X)/MAX(1,N-P), WHERE 2*F(X) IS THE RESIDUAL C SUM OF SQUARES. IF K = 1 OR 2, THEN A FINITE-DIFFERENCE C HESSIAN APPROXIMATION H IS OBTAINED. IF H IS POSITIVE C DEFINITE (OR, FOR K = 3, IF THE JACOBIAN MATRIX J AT X C IS NONSINGULAR), THEN ONE OF THE FOLLOWING IS COMPUTED... C K = 1.... SCALE * H**-1 * (J**T * J) * H**-1. C K = 2.... SCALE * H**-1. C K = 3.... SCALE * (J**T * J)**-1. C (J**T IS THE TRANSPOSE OF J, WHILE **-1 MEANS INVERSE.) C IF IV(COVREQ) IS POSITIVE, THEN BOTH FUNCTION AND GRAD- C IENT VALUES (CALLS ON CALCR AND CALCJ) ARE USED IN COM- C PUTING H (WITH STEP SIZES DETERMINED USING V(DELTA0) -- C SEE BELOW), WHILE IF IV(COVREQ) IS NEGATIVE, THEN ONLY C FUNCTION VALUES (CALLS ON CALCR) ARE USED (WITH STEP C SIZES DETERMINED USING V(DLTFDC) -- SEE BELOW). IF C IV(COVREQ) = 0, THEN NO ATTEMPT IS MADE TO COMPUTE A CO- C VARIANCE MATRIX (UNLESS IV(COVPRT) = 1, IN WHICH CASE C IV(COVREQ) = 1 IS ASSUMED). SEE IV(COVMAT) BELOW. C DEFAULT = 1. C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D (SEE REF. 1) SHOULD C BE CHOSEN. IV(DTYPE) .GE. 1 MEANS CHOOSE D AS DESCRIBED C BELOW WITH V(DFAC). IV(DTYPE) .LE. 0 MEANS THE CALLER C HAS CHOSEN D AND HAS STORED IT IN V STARTING AT C V(94 + 2*N + P*(3*P + 31)/2). DEFAULT = 1. C IV(INITS).... IV(25) TELLS HOW THE S MATRIX (SEE REF. 1) SHOULD BE C INITIALIZED. 0 MEANS INITIALIZE S TO 0 (AND START WITH C THE GAUSS-NEWTON MODEL). 1 AND 2 MEAN THAT THE CALLER C HAS STORED THE LOWER TRIANGLE OF THE INITIAL S ROWWISE IN C V STARTING AT V(87+2*P). IV(INITS) = 1 MEANS START WITH C THE GAUSS-NEWTON MODEL, WHILE IV(INITS) = 2 MEANS START C WITH THE AUGMENTED MODEL (SEE REF. 1). DEFAULT = 0. C IV(MXFCAL)... IV(17) GIVES THE MAXIMUM NUMBER OF FUNCTION EVALUATIONS C (CALLS ON CALCR, EXCLUDING THOSE USED TO COMPUTE THE CO- C VARIANCE MATRIX) ALLOWED. IF THIS NUMBER DOES NOT SUF- C FICE, THEN NL2SOL RETURNS WITH IV(1) = 9. DEFAULT = 200. C IV(MXITER)... IV(18) GIVES THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C IT ALSO INDIRECTLY LIMITS THE NUMBER OF GRADIENT EVALUA- C TIONS (CALLS ON CALCJ, EXCLUDING THOSE USED TO COMPUTE C THE COVARIANCE MATRIX) TO IV(MXITER) + 1. IF IV(MXITER) C ITERATIONS DO NOT SUFFICE, THEN NL2SOL RETURNS WITH C IV(1) = 10. DEFAULT = 150. C IV(OUTLEV)... IV(19) CONTROLS THE NUMBER AND LENGTH OF ITERATION SUM- C MARY LINES PRINTED (BY ITSMRY). IV(OUTLEV) = 0 MEANS DO C NOT PRINT ANY SUMMARY LINES. OTHERWISE, PRINT A SUMMARY C LINE AFTER EACH ABS(IV(OUTLEV)) ITERATIONS. IF IV(OUTLEV) C IS POSITIVE, THEN SUMMARY LINES OF LENGTH 117 (PLUS CARRI- C AGE CONTROL) ARE PRINTED, INCLUDING THE FOLLOWING... THE C ITERATION AND FUNCTION EVALUATION COUNTS, CURRENT FUNC- C TION VALUE (V(F) = HALF THE SUM OF SQUARES), RELATIVE C DIFFERENCE IN FUNCTION VALUES ACHIEVED BY THE LATEST STEP C (I.E., RELDF = (F0-V(F))/F0, WHERE F0 IS THE FUNCTION C VALUE FROM THE PREVIOUS ITERATION), THE RELATIVE FUNCTION C REDUCTION PREDICTED FOR THE STEP JUST TAKEN (I.E., C PRELDF = V(PREDUC) / F0, WHERE V(PREDUC) IS DESCRIBED C BELOW), THE SCALED RELATIVE CHANGE IN X (SEE V(RELDX) C BELOW), THE MODELS USED IN THE CURRENT ITERATION (G = C GAUSS-NEWTON, S=AUGMENTED), THE MARQUARDT PARAMETER C STPPAR USED IN COMPUTING THE LAST STEP, THE SIZING FACTOR C USED IN UPDATING S, THE 2-NORM OF THE SCALE VECTOR D C TIMES THE STEP JUST TAKEN (SEE REF. 1), AND NPRELDF, I.E., C V(NREDUC)/F0, WHERE V(NREDUC) IS DESCRIBED BELOW -- IF C NPRELDF IS POSITIVE, THEN IT IS THE RELATIVE FUNCTION C REDUCTION PREDICTED FOR A NEWTON STEP (ONE WITH C STPPAR = 0). IF NPRELDF IS ZERO, EITHER THE GRADIENT C VANISHES (AS DOES PRELDF) OR ELSE THE AUGMENTED MODEL C IS BEING USED AND ITS HESSIAN IS INDEFINITE (WITH PRELDF C POSITIVE). IF NPRELDF IS NEGATIVE, THEN IT IS THE NEGA- C OF THE RELATIVE FUNCTION REDUCTION PREDICTED FOR A STEP C COMPUTED WITH STEP BOUND V(LMAX0) FOR USE IN TESTING FOR C SINGULAR CONVERGENCE. C IF IV(OUTLEV) IS NEGATIVE, THEN LINES OF MAXIMUM C LENGTH 79 (OR 55 IS IV(COVPRT) = 0) ARE PRINTED, INCLUD- C ING ONLY THE FIRST 6 ITEMS LISTED ABOVE (THROUGH RELDX). C DEFAULT = 1. C IV(PARPRT)... IV(20) = 1 MEANS PRINT ANY NONDEFAULT V VALUES ON A C FRESH START OR ANY CHANGED V VALUES ON A RESTART. C IV(PARPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(PRUNIT)... IV(21) IS THE OUTPUT UNIT NUMBER ON WHICH ALL PRINTING C IS DONE. IV(PRUNIT) = 0 MEANS SUPPRESS ALL PRINTING. C (SETTING IV(PRUNIT) TO 0 IS THE ONLY WAY TO SUPPRESS THE C ONE-LINE TERMINATION REASON MESSAGE PRINTED BY ITSMRY.) C DEFAULT = STANDARD OUTPUT UNIT (UNIT 6 ON MOST SYSTEMS). C IV(SOLPRT)... IV(22) = 1 MEANS PRINT OUT THE VALUE OF X RETURNED (AS C WELL AS THE CORRESPONDING GRADIENT AND SCALE VECTOR D). C IV(SOLPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(STATPR)... IV(23) = 1 MEANS PRINT SUMMARY STATISTICS UPON RETURN- C ING. THESE CONSIST OF THE FUNCTION VALUE (HALF THE SUM C OF SQUARES) AT X, V(RELDX) (SEE BELOW), THE NUMBER OF C FUNCTION AND GRADIENT EVALUATIONS (CALLS ON CALCR AND C CALCJ RESPECTIVELY, EXCLUDING ANY CALLS USED TO COMPUTE C THE COVARIANCE), THE RELATIVE FUNCTION REDUCTIONS PREDICT- C ED FOR THE LAST STEP TAKEN AND FOR A NEWTON STEP (OR PER- C HAPS A STEP BOUNDED BY V(LMAX0) -- SEE THE DESCRIPTIONS C OF PRELDF AND NPRELDF UNDER IV(OUTLEV) ABOVE), AND (IF AN C ATTEMPT WAS MADE TO COMPUTE THE COVARIANCE) THE NUMBER OF C CALLS ON CALCR AND CALCJ USED IN TRYING TO COMPUTE THE C COVARIANCE. IV(STATPR) = 0 MEANS SKIP THIS PRINTING. C DEFAULT = 1. C IV(X0PRT).... IV(24) = 1 MEANS PRINT THE INITIAL X AND SCALE VECTOR D C (ON A FRESH START ONLY). IV(X0PRT) = 0 MEANS SKIP THIS C PRINTING. DEFAULT = 1. C C *** (SELECTED) IV OUTPUT VALUES *** C C IV(1)........ ON OUTPUT, IV(1) IS A RETURN CODE.... C 3 = X-CONVERGENCE. THE SCALED RELATIVE DIFFERENCE BE- C TWEEN THE CURRENT PARAMETER VECTOR X AND A LOCALLY C OPTIMAL PARAMETER VECTOR IS VERY LIKELY AT MOST C V(XCTOL). C 4 = RELATIVE FUNCTION CONVERGENCE. THE RELATIVE DIFFER- C ENCE BETWEEN THE CURRENT FUNCTION VALUE AND ITS LO- C CALLY OPTIMAL VALUE IS VERY LIKELY AT MOST V(RFCTOL). C 5 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE (I.E., THE C CONDITIONS FOR IV(1) = 3 AND IV(1) = 4 BOTH HOLD). C 6 = ABSOLUTE FUNCTION CONVERGENCE. THE CURRENT FUNCTION C VALUE IS AT MOST V(AFCTOL) IN ABSOLUTE VALUE. C 7 = SINGULAR CONVERGENCE. THE HESSIAN NEAR THE CURRENT C ITERATE APPEARS TO BE SINGULAR OR NEARLY SO, AND A C STEP OF LENGTH AT MOST V(LMAX0) IS UNLIKELY TO YIELD C A RELATIVE FUNCTION DECREASE OF MORE THAN V(RFCTOL). C 8 = FALSE CONVERGENCE. THE ITERATES APPEAR TO BE CONVERG- C ING TO A NONCRITICAL POINT. THIS MAY MEAN THAT THE C CONVERGENCE TOLERANCES (V(AFCTOL), V(RFCTOL), C V(XCTOL)) ARE TOO SMALL FOR THE ACCURACY TO WHICH C THE FUNCTION AND GRADIENT ARE BEING COMPUTED, THAT C THERE IS AN ERROR IN COMPUTING THE GRADIENT, OR THAT C THE FUNCTION OR GRADIENT IS DISCONTINUOUS NEAR X. C 9 = FUNCTION EVALUATION LIMIT REACHED WITHOUT OTHER CON- C VERGENCE (SEE IV(MXFCAL)). C 10 = ITERATION LIMIT REACHED WITHOUT OTHER CONVERGENCE C (SEE IV(MXITER)). C 11 = STOPX RETURNED .TRUE. (EXTERNAL INTERRUPT). SEE THE C USAGE NOTES BELOW. C 13 = F(X) CANNOT BE COMPUTED AT THE INITIAL X. C 14 = BAD PARAMETERS PASSED TO ASSESS (WHICH SHOULD NOT C OCCUR). C 15 = THE JACOBIAN COULD NOT BE COMPUTED AT X (SEE CALCJ C ABOVE). C 16 = N OR P (OR PARAMETER NN TO NL2ITR) OUT OF RANGE -- C P .LE. 0 OR N .LT. P OR NN .LT. N. C 17 = RESTART ATTEMPTED WITH N OR P (OR PAR. NN TO NL2ITR) C CHANGED. C 18 = IV(INITS) IS OUT OF RANGE. C 19...45 = V(IV(1)) IS OUT OF RANGE. C 50 = IV(1) WAS OUT OF RANGE. C 87...(86+P) = JTOL(IV(1)-86) (I.E., V(IV(1)) IS NOT C POSITIVE (SEE V(DFAC) BELOW). C IV(COVMAT)... IV(26) TELLS WHETHER A COVARIANCE MATRIX WAS COMPUTED. C IF (IV(COVMAT) IS POSITIVE, THEN THE LOWER TRIANGLE OF C THE COVARIANCE MATRIX IS STORED ROWWISE IN V STARTING AT C V(IV(COVMAT)). IF IV(COVMAT) = 0, THEN NO ATTEMPT WAS C MADE TO COMPUTE THE COVARIANCE. IF IV(COVMAT) = -1, C THEN THE FINITE-DIFFERENCE HESSIAN WAS INDEFINITE. AND C AND IF IV(COVMAT) = -2, THEN A SUCCESSFUL FINITE-DIFFER- C ENCING STEP COULD NOT BE FOUND FOR SOME COMPONENT OF X C (I.E., CALCR SET NF TO 0 FOR EACH OF TWO TRIAL STEPS). C NOTE THAT IV(COVMAT) IS RESET TO 0 AFTER EACH SUCCESSFUL C STEP, SO IF SUCH A STEP IS TAKEN AFTER A RESTART, THEN C THE COVARIANCE MATRIX WILL BE RECOMPUTED. C IV(D)........ IV(27) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT C SCALE VECTOR D. C IV(G)........ IV(28) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT C LEAST-SQUARES GRADIENT VECTOR (J**T)*R. C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCR (I.E., C FUNCTION EVALUATIONS, INCLUDING THOSE USED IN COMPUTING C THE COVARIANCE). C IV(NFCOV).... IV(40) IS THE NUMBER OF CALLS MADE ON CALCR WHEN C TRYING TO COMPUTE COVARIANCE MATRICES. C IV(NGCALL)... IV(30) IS THE NUMBER OF GRADIENT EVALUATIONS (CALLS ON C CALCJ) SO FAR DONE (INCLUDING THOSE USED FOR COMPUTING C THE COVARIANCE). C IV(NGCOV).... IV(41) IS THE NUMBER OF CALLS MADE ON CALCJ WHEN C TRYING TO COMPUTE COVARIANCE MATRICES. C IV(NITER).... IV(31) IS THE NUMBER OF ITERATIONS PERFORMED. C IV(R)........ IV(50) IS THE STARTING SUBSCRIPT IN V OF THE RESIDUAL C VECTOR R CORRESPONDING TO X. C C *** (SELECTED) V INPUT VALUES (FROM SUBROUTINE DFAULT) *** C C V(AFCTOL)... V(31) IS THE ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. C IF NL2SOL FINDS A POINT WHERE THE FUNCTION VALUE (HALF C THE SUM OF SQUARES) IS LESS THAN V(AFCTOL), AND IF NL2SOL C DOES NOT RETURN WITH IV(1) = 3, 4, OR 5, THEN IT RETURNS C WITH IV(1) = 6. DEFAULT = MAX(10**-20, MACHEP**2), WHERE C MACHEP IS THE UNIT ROUNDOFF. C V(DELTA0)... V(44) IS A FACTOR USED IN CHOOSING THE FINITE-DIFFERENCE C STEP SIZE USED IN COMPUTING THE COVARIANCE MATRIX WHEN C IV(COVREQ) = 1 OR 2. FOR COMPONENT I, STEP SIZE C V(DELTA0) * MAX(ABS(X(I)), 1/D(I)) * SIGN(X(I)) C IS USED, WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). C (IF THIS STEP RESULTS IN CALCR SETTING NF TO 0, THEN -0.5 C TIMES THIS STEP IS ALSO TRIED.) DEFAULT = MACHEP**0.5, C WHERE MACHEP IS THE UNIT ROUNDOFF. C V(DFAC)..... V(41) AND THE D0 AND JTOL ARRAYS (SEE V(D0INIT) AND C V(JTINIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN C IV(DTYPE) .GT. 0. (D IS INITIALIZED ACCORDING TO C V(DINIT).) LET D1(I) = C MAX(SQRT(JCNORM(I)**2 + MAX(S(I,I),0)), V(DFAC)*D(I)), C WHERE JCNORM(I) IS THE 2-NORM OF THE I-TH COLUMN OF THE C CURRENT JACOBIAN MATRIX AND S IS THE S MATRIX OF REF. 1. C IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I) UNLESS C D1(I) .LT. JTOL(I), IN WHICH CASE D(I) IS SET TO C MAX(D0(I), JTOL(I)). C IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST C ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION C DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER. C DEFAULT = 0.6. C V(DINIT).... V(38), IF NONNEGATIVE, IS THE VALUE TO WHICH THE SCALE C VECTOR D IS INITIALIZED. DEFAULT = 0. C V(DLTFDC)... V(40) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE C COVARIANCE MATRIX WHEN IV(COVREQ) = -1 OR -2. FOR C DIFFERENCES INVOLVING X(I), THE STEP SIZE FIRST TRIED IS C V(DLTFDC) * MAX(ABS(X(I)), 1/D(I)), C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF C THIS STEP IS TOO BIG THE FIRST TIME IT IS TRIED, I.E., IF C CALCR SETS NF TO 0, THEN -0.5 TIMES THIS STEP IS ALSO C TRIED.) DEFAULT = MACHEP**(1/3), WHERE MACHEP IS THE C UNIT ROUNDOFF. C V(D0INIT)... V(37), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED. IF C V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED D0 IN V STARTING AT V(P+87). DEFAULT = 1.0. C V(JTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE JTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED. IF C V(JTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED JTOL IN V STARTING AT V(87). DEFAULT = 10**-6. C V(LMAX0).... V(35) GIVES THE MAXIMUM 2-NORM ALLOWED FOR D TIMES THE C VERY FIRST STEP THAT NL2SOL ATTEMPTS. IT IS ALSO USED C IN TESTING FOR SINGULAR CONVERGENCE -- IF THE FUNCTION C REDUCTION PREDICTED FOR A STEP OF LENGTH BOUNDED BY C V(LMAX0) IS AT MOST V(RFCTOL) * ABS(F0), WHERE F0 IS C THE FUNCTION VALUE AT THE START OF THE CURRENT ITERATION, C AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, OR 6, C THEN IT RETURNS WITH IV(1) = 7. DEFAULT = 100. C V(RFCTOL)... V(32) IS THE RELATIVE FUNCTION CONVERGENCE TOLERANCE. C IF THE CURRENT MODEL PREDICTS A MAXIMUM POSSIBLE FUNCTION C REDUCTION (SEE V(NREDUC)) OF AT MOST V(RFCTOL)*ABS(F0) AT C THE START OF THE CURRENT ITERATION, WHERE F0 IS THE C THEN CURRENT FUNCTION VALUE, AND IF THE LAST STEP ATTEMPT- C ED ACHIEVED NO MORE THAN TWICE THE PREDICTED FUNCTION C DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 4 (OR 5). C DEFAULT = MAX(10**-10, MACHEP**(2/3)), WHERE MACHEP IS C THE UNIT ROUNDOFF. C V(TUNER1)... V(26) HELPS DECIDE WHEN TO CHECK FOR FALSE CONVERGENCE C AND TO CONSIDER SWITCHING MODELS. THIS IS DONE IF THE C ACTUAL FUNCTION DECREASE FROM THE CURRENT STEP IS NO MORE C THAN V(TUNER1) TIMES ITS PREDICTED VALUE. DEFAULT = 0.1. C V(XCTOL).... V(33) IS THE X-CONVERGENCE TOLERANCE. IF A NEWTON STEP C (SEE V(NREDUC)) IS TRIED THAT HAS V(RELDX) .LE. V(XCTOL) C AND IF THIS STEP YIELDS AT MOST TWICE THE PREDICTED FUNC- C TION DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 3 (OR 5). C (SEE THE DESCRIPTION OF V(RELDX) BELOW.) C DEFAULT = MACHEP**0.5, WHERE MACHEP IS THE UNIT ROUNDOFF. C V(XFTOL).... V(34) IS THE FALSE CONVERGENCE TOLERANCE. IF A STEP IS C TRIED THAT GIVES NO MORE THAN V(TUNER1) TIMES THE PREDICT- C ED FUNCTION DECREASE AND THAT HAS V(RELDX) .LE. V(XFTOL), C AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, 6, OR C 7, THEN IT RETURNS WITH IV(1) = 8. (SEE THE DESCRIPTION C OF V(RELDX) BELOW.) DEFAULT = 100*MACHEP, WHERE C MACHEP IS THE UNIT ROUNDOFF. C V(*)........ DFAULT SUPPLIES TO V A NUMBER OF TUNING CONSTANTS, WITH C WHICH IT SHOULD ORDINARILY BE UNNECESSARY TO TINKER. SEE C VERSION 2.2 OF THE NL2SOL USAGE SUMMARY (WHICH IS AN C APPENDIX TO REF. 1). C C *** (SELECTED) V OUTPUT VALUES *** C C V(DGNORM)... V(1) IS THE 2-NORM OF (D**-1)*G, WHERE G IS THE MOST RE- C CENTLY COMPUTED GRADIENT AND D IS THE CORRESPONDING SCALE C VECTOR. C V(DSTNRM)... V(2) IS THE 2-NORM OF D*STEP, WHERE STEP IS THE MOST RE- C CENTLY COMPUTED STEP AND D IS THE CURRENT SCALE VECTOR. C V(F)........ V(10) IS THE CURRENT FUNCTION VALUE (HALF THE SUM OF C SQUARES). C V(F0)....... V(13) IS THE FUNCTION VALUE AT THE START OF THE CURRENT C ITERATION. C V(NREDUC)... V(6), IF POSITIVE, IS THE MAXIMUM FUNCTION REDUCTION C POSSIBLE ACCORDING TO THE CURRENT MODEL, I.E., THE FUNC- C TION REDUCTION PREDICTED FOR A NEWTON STEP (I.E., C STEP = -H**-1 * G, WHERE G = (J**T) * R IS THE CURRENT C GRADIENT AND H IS THE CURRENT HESSIAN APPROXIMATION -- C H = (J**T)*J FOR THE GAUSS-NEWTON MODEL AND C H = (J**T)*J + S FOR THE AUGMENTED MODEL). C V(NREDUC) = ZERO MEANS H IS NOT POSITIVE DEFINITE. C IF V(NREDUC) IS NEGATIVE, THEN IT IS THE NEGATIVE OF C THE FUNCTION REDUCTION PREDICTED FOR A STEP COMPUTED WITH C A STEP BOUND OF V(LMAX0) FOR USE IN TESTING FOR SINGULAR C CONVERGENCE. C V(PREDUC)... V(7) IS THE FUNCTION REDUCTION PREDICTED (BY THE CURRENT C QUADRATIC MODEL) FOR THE CURRENT STEP. THIS (DIVIDED BY C V(F0)) IS USED IN TESTING FOR RELATIVE FUNCTION C CONVERGENCE. C V(RELDX).... V(17) IS THE SCALED RELATIVE CHANGE IN X CAUSED BY THE C CURRENT STEP, COMPUTED AS C MAX(ABS(D(I)*(X(I)-X0(I)), 1 .LE. I .LE. P) / C MAX(D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P), C WHERE X = X0 + STEP. C C------------------------------- NOTES ------------------------------- C C *** ALGORITHM NOTES *** C C SEE REF. 1 FOR A DESCRIPTION OF THE ALGORITHM USED. C ON PROBLEMS WHICH ARE NATURALLY WELL SCALED, BETTER PERFORM- C ANCE MAY BE OBTAINED BY SETTING V(D0INIT) = 1.0 AND IV(DTYPE) = 0, C WHICH WILL CAUSE THE SCALE VECTOR D TO BE SET TO ALL ONES. C C *** USAGE NOTES *** C C AFTER A RETURN WITH IV(1) .LE. 11, IT IS POSSIBLE TO RESTART, C I.E., TO CHANGE SOME OF THE IV AND V INPUT VALUES DESCRIBED ABOVE C AND CONTINUE THE ALGORITHM FROM THE POINT WHERE IT WAS INTERRUPT- C ED. IV(1) SHOULD NOT BE CHANGED, NOR SHOULD ANY ENTRIES OF IV C AND V OTHER THAN THE INPUT VALUES (THOSE SUPPLIED BY DFAULT). C THOSE WHO DO NOT WISH TO WRITE A CALCJ WHICH COMPUTES THE JA- C COBIAN MATRIX ANALYTICALLY SHOULD CALL NL2SNO RATHER THAN NL2SOL. C NL2SNO USES FINITE DIFFERENCES TO COMPUTE AN APPROXIMATE JACOBIAN. C THOSE WHO WOULD PREFER TO PROVIDE R AND J (THE RESIDUAL AND C JACOBIAN) BY REVERSE COMMUNICATION RATHER THAN BY WRITING SUBROU- C TINES CALCR AND CALCJ MAY CALL ON NL2ITR DIRECTLY. SEE THE COM- C MENTS AT THE BEGINNING OF NL2ITR. C THOSE WHO USE NL2SOL INTERACTIVELY MAY WISH TO SUPPLY THEIR C OWN STOPX FUNCTION, WHICH SHOULD RETURN .TRUE. IF THE BREAK KEY C HAS BEEN PRESSED SINCE STOPX WAS LAST INVOKED. THIS MAKES IT POS- C SIBLE TO EXTERNALLY INTERRUPT NL2SOL (WHICH WILL RETURN WITH C IV(1) = 11 IF STOPX RETURNS .TRUE.). C STORAGE FOR J IS ALLOCATED AT THE END OF V. THUS THE CALLER C MAY MAKE V LONGER THAN SPECIFIED ABOVE AND MAY ALLOW CALCJ TO USE C ELEMENTS OF J BEYOND THE FIRST N*P AS SCRATCH STORAGE. C C *** PORTABILITY NOTES *** C C THE NL2SOL DISTRIBUTION TAPE CONTAINS BOTH SINGLE- AND DOUBLE- C PRECISION VERSIONS OF THE NL2SOL SOURCE CODE, SO IT SHOULD BE UN- C NECESSARY TO CHANGE PRECISIONS. C ONLY THE FUNCTIONS IMDCON AND RMDCON CONTAIN MACHINE-DEPENDENT C CONSTANTS. TO CHANGE FROM ONE MACHINE TO ANOTHER, IT SHOULD C SUFFICE TO CHANGE THE (FEW) RELEVANT LINES IN THESE FUNCTIONS. C INTRINSIC FUNCTIONS ARE EXPLICITLY DECLARED. ON CERTAIN COM- C PUTERS (E.G. UNIVAC), IT MAY BE NECESSARY TO COMMENT OUT THESE C DECLARATIONS. SO THAT THIS MAY BE DONE AUTOMATICALLY BY A SIMPLE C PROGRAM, SUCH DECLARATIONS ARE PRECEDED BY A COMMENT HAVING C/+ C IN COLUMNS 1-3 AND BLANKS IN COLUMNS 4-72 AND ARE FOLLOWED BY C A COMMENT HAVING C/ IN COLUMNS 1 AND 2 AND BLANKS IN COLUMNS 3-72. C THE NL2SOL SOURCE CODE IS EXPRESSED IN 1966 ANSI STANDARD C FORTRAN. IT MAY BE CONVERTED TO FORTRAN 77 BY C COMMENTING OUT ALL LINES THAT FALL BETWEEN A LINE HAVING C/6 IN C COLUMNS 1-3 AND A LINE HAVING C/7 IN COLUMNS 1-3 AND BY REMOVING C (I.E., REPLACING BY A BLANK) THE C IN COLUMN 1 OF THE LINES THAT C FOLLOW THE C/7 LINE AND PRECEED A LINE HAVING C/ IN COLUMNS 1-2 C AND BLANKS IN COLUMNS 3-72. THESE CHANGES CONVERT SOME DATA C STATEMENTS INTO PARAMETER STATEMENTS, CONVERT SOME VARIABLES FROM C REAL TO CHARACTER*4, AND MAKE THE DATA STATEMENTS THAT INITIALIZE C THESE VARIABLES USE CHARACTER STRINGS DELIMITED BY PRIMES INSTEAD C OF HOLLERITH CONSTANTS. (SUCH VARIABLES AND DATA STATEMENTS C APPEAR ONLY IN MODULES ITSMRY AND PARCHK. PARAMETER STATEMENTS C APPEAR NEARLY EVERYWHERE.) C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C C C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1979 - WINTER 1980). C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C---------------------------- DECLARATIONS --------------------------- C EXTERNAL ITSMRY, NL2ITR C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X. C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO- C RITHM. C LOGICAL STRTED INTEGER D1, J1, NF, R1 C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER D, J, NFCALL, NFGCAL, R, TOOBIG C C *** IV SUBSCRIPT VALUES *** C C/6 DATA NFCALL/6/, NFGCAL/7/, TOOBIG/2/ C/7 C PARAMETER (NFCALL=6, NFGCAL=7, TOOBIG=2) C/ C C *** V SUBSCRIPT VALUES *** C C/6 DATA D/27/, J/33/, R/50/ C/7 C PARAMETER (D=27, J=33, R=50) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C D1 = 94 + 2*N + P*(3*P + 31)/2 IV(D) = D1 R1 = D1 + P IV(R) = R1 J1 = R1 + N IV(J) = J1 STRTED = .TRUE. IF (IV(1) .NE. 0 .AND. IV(1) .NE. 12) GO TO 40 STRTED = .FALSE. IV(NFCALL) = 1 IV(NFGCAL) = 1 C 10 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM) IF (STRTED) GO TO 20 IF (NF .GT. 0) GO TO 30 IV(1) = 13 GO TO 60 C 20 IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 40 C 30 CALL CALCJ(N, P, X, IV(NFGCAL), V(J1), UIPARM, URPARM, UFPARM) IF (IV(NFGCAL) .EQ. 0) GO TO 50 STRTED = .TRUE. C 40 CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X) IF (IV(1) - 2) 10, 30, 999 C 50 IV(1) = 15 60 CALL ITSMRY(V(D1), IV, P, V, X) C 999 RETURN C *** LAST CARD OF NL2SOL FOLLOWS *** END SUBROUTINE NL2SNO(N, P, X, CALCR, IV, V, UIPARM, URPARM, UFPARM) SNO00010 C C *** LIKE NL2SOL, BUT WITHOUT CALCJ -- MINIMIZE NONLINEAR SUM OF *** C *** SQUARES USING FINITE-DIFFERENCE JACOBIAN APPROXIMATIONS *** C *** (NL2SOL VERSION 2.2) *** C INTEGER N, P, IV(1), UIPARM(1) DOUBLE PRECISION X(P), V(1), URPARM(1) C DIMENSION IV(60+P), V(93 + N*P + 3*N + P*(3*P+33)/2) EXTERNAL CALCR, UFPARM C C----------------------------- DISCUSSION ---------------------------- C C THE PARAMETERS FOR NL2SNO ARE THE SAME AS THOSE FOR NL2SOL C (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED. INSTEAD OF CALLING C CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, NL2SNO COMPUTES C AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE C V(DLTFDJ) BELOW. NL2SNO USES FUNCTION VALUES ONLY WHEN COMPUT- C THE COVARIANCE MATRIX (RATHER THAN THE FUNCTIONS AND GRADIENTS C THAT NL2SOL MAY USE). TO DO SO, NL2SNO SETS IV(COVREQ) TO -1 IF C IV(COVPRT) = 1 WITH IV(COVREQ) = 0 AND TO MINUS ITS ABSOLUTE C VALUE OTHERWISE. THUS V(DELTA0) IS NEVER REFERENCED AND ONLY C V(DLTFDC) MATTERS -- SEE NL2SOL FOR A DESCRIPTION OF V(DLTFDC). C THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO- C BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION C COUNT IV(NFCALL) AND ARE NOT OTHERWISE REPORTED. C C V(DLTFDJ)... V(36) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE C FINITE-DIFFERENCE JACOBIAN MATRIX. FOR DIFFERENCES IN- C VOLVING X(I), THE STEP SIZE FIRST TRIED IS C V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)), C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF C THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN C SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE- C LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF. C DEFAULT = MACHEP**0.5. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS DOUBLE PRECISION DABS, DMAX1 C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL DFAULT, ITSMRY, NL2ITR, RMDCON, VSCOPY DOUBLE PRECISION RMDCON C C DFAULT... SUPPLIES DEFAULT PARAMETER VALUES. C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X. C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO- C RITHM. C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS. C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C LOGICAL STRTED INTEGER DK, D1, I, J1, J1K, K, NF, RN, R1, DINIT DOUBLE PRECISION H, HFAC, HLIM, NEGPT5, ONE, XK, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVPRT, COVREQ, D, DLTFDJ, DTYPE, J, NFCALL, NFGCAL, R, 1 TOOBIG C C/6 DATA HFAC/1.D+3/, NEGPT5/-0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/ C/7 C PARAMETER (HFAC=1.D+3, NEGPT5=-0.5D+0, ONE=1.D+0, ZERO=0.D+0) C/ C C *** IV SUBSCRIPT VALUES *** C C/6 DATA COVPRT/14/, COVREQ/15/, D/27/, DTYPE/16/, J/33/, 1 NFCALL/6/, NFGCAL/7/, R/50/, TOOBIG/2/ C/7 C PARAMETER (COVPRT=14, COVREQ=15, D=27, DTYPE=16, J=33, C 1 NFCALL=6, NFGCAL=7, R=50, TOOBIG=2) C/ C C *** V SUBSCRIPT VALUES *** C C/6 DATA DLTFDJ/36/, DINIT/38/ C/7 C PARAMETER (DLTFDJ=36) C SAVE HLIM C/ DATA HLIM/0.D+0/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C D1 = 94 + 2*N + P*(3*P + 31)/2 IV(D) = D1 R1 = D1 + P IV(R) = R1 J1 = R1 + N IV(J) = J1 RN = J1 - 1 IF (IV(1) .EQ. 0) CALL DFAULT(IV, V) IV(COVREQ) = -IABS(IV(COVREQ)) IF (IV(COVPRT) .NE. 0 .AND. IV(COVREQ) .EQ. 0) IV(COVREQ) = -1 STRTED = .TRUE. IF (IV(1) .NE. 12) GO TO 80 STRTED = .FALSE. IV(NFCALL) = 1 IV(NFGCAL) = 1 C *** INITIALIZE SCALE VECTOR D TO ONES FOR COMPUTING C *** INITIAL JACOBIAN. IF (IV(DTYPE) .GT. 0) CALL VSCOPY(P, V(D1), ONE) IF (V(DINIT).GT.ZERO) CALL VSCOPY(P, V(D1), V(DINIT)) C 10 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM) IF (STRTED) GO TO 20 IF (NF .GT. 0) GO TO 30 IV(1) = 13 GO TO 90 C 20 IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 80 C C *** COMPUTE FINITE-DIFFERENCE JACOBIAN *** C 30 J1K = J1 DK = D1 DO 70 K = 1, P XK = X(K) H = V(DLTFDJ) * DMAX1(DABS(XK), ONE/V(DK)) DK = DK + 1 40 X(K) = XK + H NF = IV(NFGCAL) CALL CALCR (N, P, X, NF, V(J1K), UIPARM, URPARM, UFPARM) IF (NF .GT. 0) GO TO 50 IF (HLIM .EQ. ZERO) HLIM = HFAC * RMDCON(3) C *** HLIM = HFAC TIMES THE UNIT ROUNDOFF *** H = NEGPT5 * H IF (DABS(H) .GE. HLIM) GO TO 40 IV(1) = 15 GO TO 90 50 X(K) = XK DO 60 I = R1, RN V(J1K) = (V(J1K) - V(I)) / H J1K = J1K + 1 60 CONTINUE 70 CONTINUE C STRTED = .TRUE. C 80 CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X) IF (IV(1) - 2) 10, 30, 999 C 90 CALL ITSMRY(V(D1), IV, P, V, X) C 999 RETURN C *** LAST CARD OF NL2SNO FOLLOWS *** END SUBROUTINE NL2ITR (D, IV, J, N, NN, P, R, V, X) ITR00010 C C *** CARRY OUT NL2SOL (NONLINEAR LEAST-SQUARES) ITERATIONS *** C *** (NL2SOL VERSION 2.2) *** C C *** PARAMETER DECLARATIONS *** C INTEGER IV(1), N, NN, P DOUBLE PRECISION D(P), J(NN,P), R(N), V(1), X(P) C DIMENSION IV(60+P), V(93 + 2*N + P*(3*P+31)/2) C C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C IV... INTEGER VALUE ARRAY. C J.... N BY P JACOBIAN MATRIX (LEAD DIMENSION NN). C N.... NUMBER OF OBSERVATIONS (COMPONENTS IN R). C NN... LEAD DIMENSION OF J. C P.... NUMBER OF PARAMETERS (COMPONENTS IN X). C R.... RESIDUAL VECTOR. C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C C *** DISCUSSION *** C C PARAMETERS IV, N, P, V, AND X ARE THE SAME AS THE CORRESPOND- C ING ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER C (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS C NOT NEEDED). MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE C TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, C AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). THE VALUES IV(D), C IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND C NL2SNO), ARE NOT REFERENCED BY NL2ITR OR THE SUBROUTINES IT CALLS. C ON A FRESH START, I.E., A CALL ON NL2ITR WITH IV(1) = 0 OR 12, C NL2ITR ASSUMES THAT R = R(X), THE RESIDUAL AT X, AND J = J(X), C THE CORRESPONDING JACOBIAN MATRIX OF R AT X. C C IV(1) = 1 MEANS THE CALLER SHOULD SET R TO R(X), THE RESIDUAL AT X, C AND CALL NL2ITR AGAIN, HAVING CHANGED NONE OF THE OTHER C PARAMETERS. AN EXCEPTION OCCURS IF R CANNOT BE EVALUATED C AT X (E.G. IF R WOULD OVERFLOW), WHICH MAY HAPPEN BECAUSE C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE NL2ITR TO IG- C NORE R AND TRY A SMALLER STEP. THE PARAMETER NF THAT C NL2SOL PASSES TO CALCR (FOR POSSIBLE USE BY CALCJ) IS A C COPY OF IV(NFCALL) = IV(6). C IV(1) = 2 MEANS THE CALLER SHOULD SET J TO J(X), THE JACOBIAN MATRIX C OF R AT X, AND CALL NL2ITR AGAIN. THE CALLER MAY CHANGE C D AT THIS TIME, BUT SHOULD NOT CHANGE ANY OF THE OTHER C PARAMETERS. THE PARAMETER NF THAT NL2SOL PASSES TO C CALCJ IS IV(NFGCAL) = IV(7). IF J CANNOT BE EVALUATED C AT X, THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN WHICH C CASE NL2ITR WILL RETURN WITH IV(1) = 15. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C (SEE NL2SOL FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DUMMY, DIG1, G1, G01, H0, H1, I, IM1, IPIVI, IPIVK, IPIV1, 1 IPK, K, KM1, L, LKY1, LMAT1, LSTGST, M, PP1O2, QTR1, 2 RDK, RD0, RD1, RSAVE1, SMH, SSTEP, STEP1, STPMOD, S1, 3 TEMP1, TEMP2, W1, X01 DOUBLE PRECISION E, RDOF1, STTSST, T, T1 C C *** CONSTANTS *** C DOUBLE PRECISION HALF, NEGONE, ONE, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS DOUBLE PRECISION DABS C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL ASSESS, COVCLC, DOTPRD, DUPDAT, GQTSTP, ITSMRY, LMSTEP, 1 PARCHK, QAPPLY, QRFACT, RPTMUL, SLUPDT, SLVMUL, STOPX, 2 VAXPY, VCOPY, VSCOPY, V2NORM LOGICAL STOPX DOUBLE PRECISION DOTPRD, V2NORM C C ASSESS... ASSESSES CANDIDATE STEP. C COVCLC... COMPUTES COVARIANCE MATRIX. C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS. C DUPDAT... UPDATES SCALE VECTOR D. C GQTSTP... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL). C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X. C LMSTEP... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL). C PARCHK... CHECKS VALIDITY OF INPUT IV AND V VALUES. C QAPPLY... APPLIES ORTHOGONAL MATRIX Q FROM QRFACT TO A VECTOR. C QRFACT... COMPUTES QR DECOMPOSITION OF A MATRIX VIA HOUSEHOLDER TRANS. C RPTMUL... MULTIPLIES VECTOR BY THE R MATRIX (AND/OR ITS TRANSPOSE) C STORED BY QRFACT. C SLUPDT... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI- C ANGLE OF A SYMMETRIC MATRIX. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C VAXPY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C VCOPY.... COPIES ONE VECTOR TO ANOTHER. C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V2NORM... RETURNS THE 2-NORM OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER CNVCOD, COSMIN, COVMAT, COVPRT, COVREQ, DGNORM, DIG, 1 DINIT, DSTNRM, DTYPE, D0INIT, F, FDIF, FUZZ, 2 F0, G, GTSTEP, H, IERR, INCFAC, INITS, IPIVOT, IPIV0, IRC, 3 JTINIT, JTOL1, KAGQT, KALM, LKY, LMAT, LMAX0, MODE, MODEL, 4 MXFCAL, MXITER, NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL, 5 NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC, RADINC, 6 RADIUS, RAD0, RD, RESTOR, RLIMIT, RSAVE, S, SIZE, STEP, 7 STGLIM, STLSTG, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4, 8 TUNER5, VSAVE1, W, WSCALE, XIRC, X0 C C *** IV SUBSCRIPT VALUES *** C C/6 DATA CNVCOD/34/, COVMAT/26/, COVPRT/14/, 1 COVREQ/15/, DIG/43/, DTYPE/16/, G/28/, H/44/, 2 IERR/32/, INITS/25/, IPIVOT/61/, IPIV0/60/, 3 IRC/3/, KAGQT/35/, KALM/36/, LKY/37/, LMAT/58/, 4 MODE/38/, MODEL/5/, MXFCAL/17/, MXITER/18/, 5 NFCALL/6/, NFGCAL/7/, NFCOV/40/, NGCOV/41/, 6 NGCALL/30/, NITER/31/, QTR/49/, 7 RADINC/8/, RD/51/, RESTOR/9/, RSAVE/52/, S/53/, 8 STEP/55/, STGLIM/11/, STLSTG/56/, SUSED/57/, 9 SWITCH/12/, TOOBIG/2/, W/59/, XIRC/13/, X0/60/ C/7 C PARAMETER (CNVCOD=34, COVMAT=26, COVPRT=14, C 1 COVREQ=15, DIG=43, DTYPE=16, G=28, H=44, C 2 IERR=32, INITS=25, IPIVOT=61, IPIV0=60, C 3 IRC=3, KAGQT=35, KALM=36, LKY=37, LMAT=58, C 4 MODE=38, MODEL=5, MXFCAL=17, MXITER=18, C 5 NFCALL=6, NFGCAL=7, NFCOV=40, NGCOV=41, C 6 NGCALL=30, NITER=31, QTR=49, C 7 RADINC=8, RD=51, RESTOR=9, RSAVE=52, S=53, C 8 STEP=55, STGLIM=11, STLSTG=56, SUSED=57, C 9 SWITCH=12, TOOBIG=2, W=59, XIRC=13, X0=60) C/ C C *** V SUBSCRIPT VALUES *** C C/6 DATA COSMIN/43/, DGNORM/1/, DINIT/38/, DSTNRM/2/, 1 D0INIT/37/, F/10/, FDIF/11/, FUZZ/45/, 2 F0/13/, GTSTEP/4/, INCFAC/23/, 3 JTINIT/39/, JTOL1/87/, LMAX0/35/, 4 NVSAVE/9/, PHMXFC/21/, PREDUC/7/, 5 RADFAC/16/, RADIUS/8/, RAD0/9/, RLIMIT/42/, 6 SIZE/47/, STPPAR/5/, TUNER4/29/, TUNER5/30/, 7 VSAVE1/78/, WSCALE/48/ C/7 C PARAMETER (COSMIN=43, DGNORM=1, DINIT=38, DSTNRM=2, C 1 D0INIT=37, F=10, FDIF=11, FUZZ=45, C 2 F0=13, GTSTEP=4, INCFAC=23, C 3 JTINIT=39, JTOL1=87, LMAX0=35, C 4 NVSAVE=9, PHMXFC=21, PREDUC=7, C 5 RADFAC=16, RADIUS=8, RAD0=9, RLIMIT=42, C 6 SIZE=47, STPPAR=5, TUNER4=29, TUNER5=30, C 7 VSAVE1=78, WSCALE=48) C/ C C C/6 DATA HALF/0.5D+0/, NEGONE/-1.D+0/, ONE/1.D+0/, ZERO/0.D+0/ C/7 C PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ZERO=0.D+0) C/ C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 20 IF (I .EQ. 2) GO TO 50 C C *** CHECK VALIDITY OF IV AND V INPUT VALUES *** C C *** NOTE -- IF IV(1) = 0, THEN PARCHK CALLS DFAULT(IV, V) *** CALL PARCHK(IV, N, NN, P, V) I = IV(1) - 2 IF (I .GT. 10) GO TO 999 GO TO (350, 350, 350, 350, 350, 350, 195, 160, 195, 10), I C C *** INITIALIZATION AND STORAGE ALLOCATION *** C 10 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(STGLIM) = 2 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(COVMAT) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(KALM) = -1 IV(RADINC) = 0 IV(S) = JTOL1 + 2*P PP1O2 = P * (P + 1) / 2 IV(X0) = IV(S) + PP1O2 IV(STEP) = IV(X0) + P IV(STLSTG) = IV(STEP) + P IV(DIG) = IV(STLSTG) + P IV(G) = IV(DIG) + P IV(LKY) = IV(G) + P IV(RD) = IV(LKY) + P IV(RSAVE) = IV(RD) + P IV(QTR) = IV(RSAVE) + N IV(H) = IV(QTR) + N IV(W) = IV(H) + PP1O2 IV(LMAT) = IV(W) + 4*P + 7 C +++ LENGTH OF W = P*(P+9)/2 + 7. LMAT IS CONTAINED IN W. IF (V(DINIT) .GE. ZERO) CALL VSCOPY(P, D, V(DINIT)) IF (V(JTINIT) .GT. ZERO) CALL VSCOPY(P, V(JTOL1), V(JTINIT)) I = JTOL1 + P IF (V(D0INIT) .GT. ZERO) CALL VSCOPY(P, V(I), V(D0INIT)) V(RAD0) = ZERO V(STPPAR) = ZERO V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C C *** SET INITIAL MODEL AND S MATRIX *** C IV(MODEL) = 1 IF (IV(INITS) .EQ. 2) IV(MODEL) = 2 S1 = IV(S) IF (IV(INITS) .EQ. 0) CALL VSCOPY(PP1O2, V(S1), ZERO) C C *** COMPUTE FUNCTION VALUE (HALF THE SUM OF SQUARES) *** C 20 T = V2NORM(N, R) IF (T .GT. V(RLIMIT)) IV(TOOBIG) = 1 IF (IV(TOOBIG) .NE. 0) GO TO 30 V(F) = HALF * T**2 30 IF (IV(MODE)) 40, 350, 730 C 40 IF (IV(TOOBIG) .EQ. 0) GO TO 60 IV(1) = 13 GO TO 900 C C *** MAKE SURE JACOBIAN COULD BE COMPUTED *** C 50 IF (IV(NFGCAL) .NE. 0) GO TO 60 IV(1) = 15 GO TO 900 C C *** COMPUTE GRADIENT *** C 60 IV(KALM) = -1 G1 = IV(G) DO 70 I = 1, P V(G1) = DOTPRD(N, R, J(1,I)) G1 = G1 + 1 70 CONTINUE IF (IV(MODE) .GT. 0) GO TO 710 C C *** UPDATE D AND MAKE COPIES OF R FOR POSSIBLE USE LATER *** C IF (IV(DTYPE) .GT. 0) CALL DUPDAT(D, IV, J, N, NN, P, V) RSAVE1 = IV(RSAVE) CALL VCOPY(N, V(RSAVE1), R) QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) C C *** COMPUTE D**-1 * GRADIENT *** C G1 = IV(G) DIG1 = IV(DIG) K = DIG1 DO 80 I = 1, P V(K) = V(G1) / D(I) K = K + 1 G1 = G1 + 1 80 CONTINUE V(DGNORM) = V2NORM(P, V(DIG1)) C IF (IV(CNVCOD) .NE. 0) GO TO 700 IF (IV(MODE) .EQ. 0) GO TO 570 IV(MODE) = 0 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 150 CALL ITSMRY(D, IV, P, V, X) 160 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 170 IV(1) = 10 GO TO 900 170 IV(NITER) = K + 1 C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 185 STEP1 = IV(STEP) DO 180 I = 1, P V(STEP1) = D(I) * V(STEP1) STEP1 = STEP1 + 1 180 CONTINUE STEP1 = IV(STEP) V(RADIUS) = V(RADFAC) * V2NORM(P, V(STEP1)) C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 185 X01 = IV(X0) V(F0) = V(F) IV(KAGQT) = -1 IV(IRC) = 4 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(MODEL) C C *** COPY X TO X0 *** C CALL VCOPY(P, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 190 IF (.NOT. STOPX(DUMMY)) GO TO 200 IV(1) = 11 GO TO 205 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 195 IF (V(F) .GE. V(F0)) GO TO 200 V(RADFAC) = ONE K = IV(NITER) GO TO 170 C 200 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 210 IV(1) = 9 205 IF (V(F) .GE. V(F0)) GO TO 900 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 560 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 210 STEP1 = IV(STEP) W1 = IV(W) IF (IV(MODEL) .EQ. 2) GO TO 240 C C *** COMPUTE LEVENBERG-MARQUARDT STEP *** C QTR1 = IV(QTR) IF (IV(KALM) .GE. 0) GO TO 215 RD1 = IV(RD) IF (-1 .EQ. IV(KALM)) CALL QRFACT(NN, N, P, J, V(RD1), 1 IV(IPIVOT), IV(IERR), 0, V(W1)) CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR)) 215 H1 = IV(H) IF (H1 .GT. 0) GO TO 230 C C *** COPY R MATRIX TO H *** C H1 = -H1 IV(H) = H1 K = H1 RD1 = IV(RD) V(K) = V(RD1) IF (P .EQ. 1) GO TO 230 DO 220 I = 2, P CALL VCOPY(I-1, V(K+1), J(1,I)) K = K + I RD1 = RD1 + 1 V(K) = V(RD1) 220 CONTINUE C 230 G1 = IV(G) CALL LMSTEP(D, V(G1), IV(IERR), IV(IPIVOT), IV(KALM), P, 1 V(QTR1), V(H1), V(STEP1), V, V(W1)) GO TO 310 C C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL) *** C 240 IF (IV(H) .GT. 0) GO TO 300 C C *** SET H TO D**-1 * ( (J**T)*J + S) ) * D**-1. *** C H1 = -IV(H) IV(H) = H1 S1 = IV(S) IF (-1 .NE. IV(KALM)) GO TO 270 C C *** J IS IN ITS ORIGINAL FORM *** C DO 260 I = 1, P T = ONE / D(I) DO 250 K = 1, I V(H1) = T*(DOTPRD(N,J(1,I),J(1,K))+V(S1)) / D(K) H1 = H1 + 1 S1 = S1 + 1 250 CONTINUE 260 CONTINUE GO TO 300 C C *** LMSTEP HAS APPLIED QRFACT TO J *** C 270 SMH = S1 - H1 H0 = H1 - 1 IPIV1 = IV(IPIVOT) T1 = ONE / D(IPIV1) RD0 = IV(RD) - 1 RDOF1 = V(RD0 + 1) DO 290 I = 1, P L = IPIV0 + I IPIVI = IV(L) H1 = H0 + IPIVI*(IPIVI-1)/2 L = H1 + IPIVI M = L + SMH C *** V(L) = H(IPIVOT(I), IPIVOT(I)) *** C *** V(M) = S(IPIVOT(I), IPIVOT(I)) *** T = ONE / D(IPIVI) RDK = RD0 + I E = V(RDK)**2 IF (I .GT. 1) E = E + DOTPRD(I-1, J(1,I), J(1,I)) V(L) = (E + V(M)) * T**2 IF (I .EQ. 1) GO TO 290 L = H1 + IPIV1 IF (IPIVI .LT. IPIV1) L = L + 1 ((IPIV1-IPIVI)*(IPIV1+IPIVI-3))/2 M = L + SMH C *** V(L) = H(IPIVOT(I), IPIVOT(1)) *** C *** V(M) = S(IPIVOT(I), IPIVOT(1)) *** V(L) = T * (RDOF1 * J(1,I) + V(M)) * T1 IF (I .EQ. 2) GO TO 290 IM1 = I - 1 DO 280 K = 2, IM1 IPK = IPIV0 + K IPIVK = IV(IPK) L = H1 + IPIVK IF (IPIVI .LT. IPIVK) L = L + 1 ((IPIVK-IPIVI)*(IPIVK+IPIVI-3))/2 M = L + SMH C *** V(L) = H(IPIVOT(I), IPIVOT(K)) *** C *** V(M) = S(IPIVOT(I), IPIVOT(K)) *** KM1 = K - 1 RDK = RD0 + K V(L) = T * (DOTPRD(KM1, J(1,I), J(1,K)) + 1 V(RDK)*J(K,I) + V(M)) / D(IPIVK) 280 CONTINUE 290 CONTINUE C C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP *** C 300 H1 = IV(H) DIG1 = IV(DIG) LMAT1 = IV(LMAT) CALL GQTSTP(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1), 1 V, V(W1)) C C C *** COMPUTE R(X0 + STEP) *** C 310 IF (IV(IRC) .EQ. 6) GO TO 350 X01 = IV(X0) STEP1 = IV(STEP) CALL VAXPY(P, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 IV(TOOBIG) = 0 GO TO 999 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 350 STEP1 = IV(STEP) LSTGST = IV(STLSTG) X01 = IV(X0) CALL ASSESS(D, IV, P, V(STEP1), V(LSTGST), V, X, V(X01)) C C *** IF NECESSARY, SWITCH MODELS AND/OR RESTORE R *** C IF (IV(SWITCH) .EQ. 0) GO TO 360 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 CALL VCOPY(NVSAVE, V, V(VSAVE1)) 360 IF (IV(RESTOR) .EQ. 0) GO TO 390 RSAVE1 = IV(RSAVE) CALL VCOPY(N, R, V(RSAVE1)) 390 L = IV(IRC) - 4 STPMOD = IV(MODEL) IF (L .GT. 0) GO TO (410,440,450,450,450,450,450,450,640,570), L C C *** DECIDE WHETHER TO CHANGE MODELS *** C E = V(PREDUC) - V(FDIF) SSTEP = IV(LKY) S1 = IV(S) CALL SLVMUL(P, V(SSTEP), V(S1), V(STEP1)) STTSST = HALF * DOTPRD(P, V(STEP1), V(SSTEP)) IF (IV(MODEL) .EQ. 1) STTSST = -STTSST IF (DABS(E + STTSST) * V(FUZZ) .GE. DABS(E)) GO TO 400 C C *** SWITCH MODELS *** C IV(MODEL) = 3 - IV(MODEL) IF (IV(MODEL) .EQ. 1) IV(KAGQT) = -1 IF (IV(MODEL) .EQ. 2 .AND. IV(KALM) .GT. 0) IV(KALM) = 0 IF (-2 .LT. L) GO TO 480 IV(H) = -IABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 CALL VCOPY(NVSAVE, V(VSAVE1), V) GO TO 420 C 400 IF (-3 .LT. L) GO TO 480 C C *** RECOMPUTE STEP WITH DECREASED RADIUS *** C V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 190 C C *** RECOMPUTE STEP, SAVING V VALUES AND R IF NECESSARY *** C 410 V(RADIUS) = V(RADFAC) * V(DSTNRM) 420 IF (V(F) .GE. V(F0)) GO TO 190 RSAVE1 = IV(RSAVE) CALL VCOPY(N, V(RSAVE1), R) GO TO 190 C C *** COMPUTE STEP OF LENGTH V(LMAX0) FOR SINGULAR CONVERGENCE TEST C 440 V(RADIUS) = V(LMAX0) GO TO 210 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 450 IV(CNVCOD) = L IF (V(F) .GE. V(F0)) GO TO 700 IF (IV(XIRC) .EQ. 14) GO TO 700 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 480 IV(COVMAT) = 0 C C *** SET LKY = (J(X0)**T) * R(X) *** C LKY1 = IV(LKY) IF (IV(KALM) .GE. 0) GO TO 500 C C *** JACOBIAN HAS NOT BEEN MODIFIED *** C DO 490 I = 1, P V(LKY1) = DOTPRD(N, J(1,I), R) LKY1 = LKY1 + 1 490 CONTINUE GO TO 510 C C *** QRFACT HAS BEEN APPLIED TO J. STORE COPY OF R IN QTR AND *** C *** APPLY Q TO IT. *** C 500 QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR)) C C *** MULTIPLY TOP P-VECTOR IN QTR BY PERMUTED UPPER TRIANGLE *** C *** STORED BY QRFACT IN J AND RD. *** C RD1 = IV(RD) TEMP1 = IV(STLSTG) CALL RPTMUL(3, IV(IPIVOT), J, NN, P, V(RD1), V(QTR1), V(LKY1), 1 V(TEMP1)) C C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS *** C 510 IF (IV(IRC) .NE. 3) GO TO 560 STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(X0) C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C IF (STPMOD .EQ. 2) GO TO 530 C C *** STEP COMPUTED USING GAUSS-NEWTON MODEL *** C *** -- QRFACT HAS BEEN APPLIED TO J *** C RD1 = IV(RD) CALL RPTMUL(2, IV(IPIVOT), J, NN, P, V(RD1), 1 V(STEP1), V(TEMP1), V(TEMP2)) GO TO 560 C C *** STEP COMPUTED USING AUGMENTED MODEL *** C 530 H1 = IV(H) K = TEMP2 DO 540 I = 1, P V(K) = D(I) * V(STEP1) K = K + 1 STEP1 = STEP1 + 1 540 CONTINUE CALL SLVMUL(P, V(TEMP1), V(H1), V(TEMP2)) DO 550 I = 1, P V(TEMP1) = D(I) * V(TEMP1) TEMP1 = TEMP1 + 1 550 CONTINUE C C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE *** C 560 IV(NGCALL) = IV(NGCALL) + 1 G1 = IV(G) G01 = IV(W) CALL VCOPY(P, V(G01), V(G1)) IV(1) = 2 GO TO 999 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 570 G01 = IV(W) G1 = IV(G) CALL VAXPY(P, V(G01), NEGONE, V(G01), V(G1)) STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(X0) IF (IV(IRC) .NE. 3) GO TO 600 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) *** C K = TEMP1 L = G01 DO 580 I = 1, P V(K) = (V(K) - V(L)) / D(I) K = K + 1 L = L + 1 580 CONTINUE C C *** DO GRADIENT TESTS *** C IF (V2NORM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 590 IF (DOTPRD(P, V(G1), V(STEP1)) 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 600 590 V(RADFAC) = V(INCFAC) C C *** FINISH COMPUTING LKY = ((J(X) - J(X0))**T) * R *** C C *** CURRENTLY LKY = (J(X0)**T) * R *** C 600 LKY1 = IV(LKY) CALL VAXPY(P, V(LKY1), NEGONE, V(LKY1), V(G1)) C C *** DETERMINE SIZING FACTOR V(SIZE) *** C C *** SET TEMP1 = S * STEP *** S1 = IV(S) CALL SLVMUL(P, V(TEMP1), V(S1), V(STEP1)) C T1 = DABS(DOTPRD(P, V(STEP1), V(TEMP1))) T = DABS(DOTPRD(P, V(STEP1), V(LKY1))) V(SIZE) = ONE IF (T .LT. T1) V(SIZE) = T / T1 C C *** UPDATE S *** C CALL SLUPDT(V(S1), V(COSMIN), P, V(SIZE), V(STEP1), V(TEMP1), 1 V(TEMP2), V(G01), V(WSCALE), V(LKY1)) IV(1) = 2 GO TO 150 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 640 IV(1) = 14 GO TO 900 C C *** CONVERGENCE OBTAINED -- COMPUTE COVARIANCE MATRIX IF DESIRED *** C 700 IF (IV(COVREQ) .EQ. 0 .AND. IV(COVPRT) .EQ. 0) GO TO 760 IF (IV(COVMAT) .NE. 0) GO TO 760 IF (IV(CNVCOD) .GE. 7) GO TO 760 IV(MODE) = 0 710 CALL COVCLC(I, D, IV, J, N, NN, P, R, V, X) GO TO (720, 720, 740, 750), I 720 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(RESTOR) = I IV(1) = 1 GO TO 999 C 730 IF (IV(RESTOR) .EQ. 1 .OR. IV(TOOBIG) .NE. 0) GO TO 710 IV(NFGCAL) = IV(NFCALL) 740 IV(NGCOV) = IV(NGCOV) + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(1) = 2 GO TO 999 C 750 IV(MODE) = 0 IF (IV(NITER) .EQ. 0) IV(MODE) = -1 C 760 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 900 CALL ITSMRY(D, IV, P, V, X) C 999 RETURN C C *** LAST CARD OF NL2ITR FOLLOWS *** END SUBROUTINE ASSESS (D, IV, P, STEP, STLSTG, V, X, X0) ASS00010 C C *** ASSESS CANDIDATE STEP (NL2SOL VERSION 2.2) *** C INTEGER P, IV(13) DOUBLE PRECISION D(P), STEP(P), STLSTG(P), V(35), X(P), X0(P) C C *** PURPOSE *** C C THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION C ROUTINE TO ASSESS THE NEXT CANDIDATE STEP. IT MAY RECOMMEND ONE C OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM- C PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE C TO CONVERGENCE OR FALSE CONVERGENCE. SEE THE RETURN CODE LISTING C BELOW. C C-------------------------- PARAMETER USAGE -------------------------- C C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF IV VALUES REFERENCED. C D (IN) SCALE VECTOR USED IN COMPUTING V(RELDX) -- SEE BELOW. C P (IN) NUMBER OF PARAMETERS BEING OPTIMIZED. C STEP (I/O) ON INPUT, STEP IS THE STEP TO BE ASSESSED. IT IS UN- C CHANGED ON OUTPUT UNLESS A PREVIOUS STEP ACHIEVED A C BETTER OBJECTIVE FUNCTION REDUCTION, IN WHICH CASE STLSTG C WILL HAVE BEEN COPIED TO STEP. C STLSTG (I/O) WHEN ASSESS RECOMMENDS RECOMPUTING STEP EVEN THOUGH THE C CURRENT (OR A PREVIOUS) STEP YIELDS AN OBJECTIVE FUNC- C TION DECREASE, IT SAVES IN STLSTG THE STEP THAT GAVE THE C BEST FUNCTION REDUCTION SEEN SO FAR (IN THE CURRENT ITERA- C TION). IF THE RECOMPUTED STEP YIELDS A LARGER FUNCTION C VALUE, THEN STEP IS RESTORED FROM STLSTG AND C X = X0 + STEP IS RECOMPUTED. C V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF V VALUES REFERENCED. C X (I/O) ON INPUT, X = X0 + STEP IS THE POINT AT WHICH THE OBJEC- C TIVE FUNCTION HAS JUST BEEN EVALUATED. IF AN EARLIER C STEP YIELDED A BIGGER FUNCTION DECREASE, THEN X IS C RESTORED TO THE CORRESPONDING EARLIER VALUE. OTHERWISE, C IF THE CURRENT STEP DOES NOT GIVE ANY FUNCTION DECREASE, C THEN X IS RESTORED TO X0. C X0 (IN) INITIAL OBJECTIVE FUNCTION PARAMETER VECTOR (AT THE C START OF THE CURRENT ITERATION). C C *** IV VALUES REFERENCED *** C C IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION, C IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS C SET WHEN STEP IS DEFINITELY TO BE ACCEPTED). ON INPUT C AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE C UNCHANGED SINCE THE PREVIOUS RETURN OF ASSESS. C ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE C FOLLOWING VALUES... C 1 = SWITCH MODELS OR TRY SMALLER STEP. C 2 = SWITCH MODELS OR ACCEPT STEP. C 3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT C TESTS. C 4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED. C 5 = RECOMPUTE STEP (USING THE SAME MODEL). C 6 = RECOMPUTE STEP WITH RADIUS = V(LMAX0) BUT DO NOT C EVAULATE THE OBJECTIVE FUNCTION. C 7 = X-CONVERGENCE (SEE V(XCTOL)). C 8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)). C 9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE. C 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)). C 11 = SINGULAR CONVERGENCE (SEE V(LMAX0)). C 12 = FALSE CONVERGENCE (SEE V(XFTOL)). C 13 = IV(IRC) WAS OUT OF RANGE ON INPUT. C RETURN CODE I HAS PRECDENCE OVER I+1 FOR I = 9, 10, 11. C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL). C IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING C THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION. C IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION, C THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT. C IV(NFCALL) (IN) INVOCATION COUNT FOR THE OBJECTIVE FUNCTION. C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST C FUNCTION REDUCTION THIS ITERATION. IV(NFGCAL) REMAINS C UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED. C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER C OF DECREASES) SO FAR THIS ITERATION. C IV(RESTOR) (OUT) SET TO 0 UNLESS X AND V(F) HAVE BEEN RESTORED, IN C WHICH CASE ASSESS SETS IV(RESTOR) = 1. C IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE C CURRENT ITERATION. C IV(STGLIM) (IN) MAXIMUM NUMBER OF MODELS TO CONSIDER. C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT C GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL, C IN WHICH CASE ASSESS SETS IV(SWITCH) = 1. C IV(TOOBIG) (IN) IS NONZERO IF STEP WAS TOO BIG (E.G. IF IT CAUSED C OVERFLOW). C IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF C CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS. C C *** V VALUES REFERENCED *** C C V(AFCTOL) (IN) ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. IF THE C ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS C THAN V(AFCTOL), THEN ASSESS RETURNS WITH IV(IRC) = 10. C V(DECFAC) (IN) FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS C NONZERO. C V(DSTNRM) (IN) THE 2-NORM OF D*STEP. C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP. C V(DST0) (IN) THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED, C I.E., FOR V(NREDUC) .GE. 0). C V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC- C TION VALUE AT X. IF X IS RESTORED TO A PREVIOUS VALUE, C THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE. C V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT C VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION C DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE). C V(FLSTGD) (I/O) SAVED VALUE OF V(F). C V(F0) (IN) OBJECTIVE FUNCTION VALUE AT START OF ITERATION. C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP. C V(GTSTEP) (IN) INNER PRODUCT BETWEEN STEP AND GRADIENT. C V(INCFAC) (IN) MINIMUM FACTOR BY WHICH TO INCREASE RADIUS. C V(LMAX0) (IN) MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND). C IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE C WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, 9, C OR 10 DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAX0), AND IF C V(PREDUC) .LE. V(RFCTOL) * ABS(V(F0)), THEN ASSESS RE- C TURNS WITH IV(IRC) = 11. IF SO DOING APPEARS WORTHWHILE, C THEN ASSESS REPEATS THIS TEST WITH V(PREDUC) COMPUTED FOR C A STEP OF LENGTH V(LMAX0) (BY A RETURN WITH IV(IRC) = 6). C V(NREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C NEWTON STEP. IF ASSESS IS CALLED WITH IV(IRC) = 6, I.E., C IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAX0) FOR C USE IN THE SINGULAR CONVERVENCE TEST, THEN V(NREDUC) IS C SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED. C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP. C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C CURRENT STEP. C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS, C WHICH SHOULD BE V(RADFAC)*DST, WHERE DST IS EITHER THE C OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF C DIAG(NEWD)*STEP FOR THE OUTPUT VALUE OF STEP AND THE C UPDATED VERSION, NEWD, OF THE SCALE VECTOR D. FOR C IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED. C V(RDFCMN) (IN) MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT C VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1. C V(RDFCMX) (IN) MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0. C V(RELDX) (OUT) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED C BY FUNCTION RELDST AS C MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) / C MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P). C IF AN ACCEPTABLE STEP IS RETURNED, THEN V(RELDX) IS COM- C PUTED USING THE OUTPUT (POSSIBLY RESTORED) VALUES OF X C AND STEP. OTHERWISE IT IS COMPUTED USING THE INPUT C VALUES. C V(RFCTOL) (IN) RELATIVE FUNCTION CONVERGENCE TOLERANCE. IF THE C ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE- C DICTED AND V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)), THEN C ASSESS RETURNS WITH IV(IRC) = 8 OR 9. SEE ALSO V(LMAX0). C V(STPPAR) (IN) MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP. C V(TUNER1) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS MUCH LESS THAN EXPECTED. SUGGESTED C VALUE = 0.1. C V(TUNER2) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP. SUGGESTED C VALUE = 10**-4. C V(TUNER3) (IN) TUNING CONSTANT USED TO DECIDE IF THE RADIUS C SHOULD BE INCREASED. SUGGESTED VALUE = 0.75. C V(XCTOL) (IN) X-CONVERGENCE CRITERION. IF STEP IS A NEWTON STEP C (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING C AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN C ASSESS RETURNS IV(IRC) = 7 OR 9. C V(XFTOL) (IN) FALSE CONVERGENCE TOLERANCE. IF STEP GAVE NO OR ONLY C A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL), C THEN ASSESS RETURNS WITH IV(IRC) = 12. C C------------------------------- NOTES ------------------------------- C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR C LEAST-SQUARES) PACKAGE. IT MAY BE USED IN ANY UNCONSTRAINED C MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER, C OR LEVENBERG-MARQUARDT STEPS. C C *** ALGORITHM NOTES *** C C SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL C SWITCHING STRATEGIES. WHILE NL2SOL CONSIDERS ONLY TWO MODELS, C ASSESS IS DESIGNED TO HANDLE ANY NUMBER OF MODELS. C C *** USAGE NOTES *** C C ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES C STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND C V(PREDUC) NEED HAVE BEEN INITIALIZED. BETWEEN CALLS, NO I/O C VALUES EXECPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER- C ANCES SHOULD BE CHANGED. C AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN C CHANGE THE STOPPING TOLERANCES AND CALL ASSESS AGAIN, IN WHICH C CASE THE STOPPING TESTS WILL BE REPEATED. C C *** REFERENCES *** C C (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1981), C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, C ACM TRANS. MATH. SOFTWARE, VOL. 7, NO. 3. C C (2) POWELL, M.J.D. (1970) A FORTRAN SUBROUTINE FOR SOLVING C SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL C METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY C P. RABINOWITZ, GORDON AND BREACH, LONDON. C C *** HISTORY *** C C JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH C IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY. C DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE C PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS C PRESENT FORM (FALL 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL RELDST, VCOPY DOUBLE PRECISION RELDST C C VCOPY.... COPIES ONE VECTOR TO ANOTHER. C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS DOUBLE PRECISION DABS, DMAX1 C/ C *** NO COMMON BLOCKS *** C C-------------------------- LOCAL VARIABLES -------------------------- C LOGICAL GOODX INTEGER I, NFC DOUBLE PRECISION EMAX, GTS, HALF, ONE, RELDX1, RFAC1, TWO, XMAX, 1 ZERO C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0, 1 GTSLST, GTSTEP, INCFAC, IRC, LMAX0, MLSTGD, MODEL, NFCALL, 2 NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN, 3 RDFCMX, RELDX, RESTOR, RFCTOL, STAGE, STGLIM, STPPAR, 4 SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL, XFTOL, 5 XIRC C C *** DATA INITIALIZATIONS *** C C/6 DATA HALF/0.5D+0/, ONE/1.D+0/, TWO/2.D+0/, ZERO/0.D+0/ C/7 C PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0) C/ C C/6 DATA IRC/3/, MLSTGD/4/, MODEL/5/, NFCALL/6/, 1 NFGCAL/7/, RADINC/8/, RESTOR/9/, STAGE/10/, 2 STGLIM/11/, SWITCH/12/, TOOBIG/2/, XIRC/13/ C/7 C PARAMETER (IRC=3, MLSTGD=4, MODEL=5, NFCALL=6, C 1 NFGCAL=7, RADINC=8, RESTOR=9, STAGE=10, C 2 STGLIM=11, SWITCH=12, TOOBIG=2, XIRC=13) C/ C/6 DATA AFCTOL/31/, DECFAC/22/, DSTNRM/2/, DST0/3/, 1 DSTSAV/18/, F/10/, FDIF/11/, FLSTGD/12/, F0/13/, 2 GTSLST/14/, GTSTEP/4/, INCFAC/23/, 3 LMAX0/35/, NREDUC/6/, PLSTGD/15/, PREDUC/7/, 4 RADFAC/16/, RDFCMN/24/, RDFCMX/25/, 5 RELDX/17/, RFCTOL/32/, STPPAR/5/, TUNER1/26/, 6 TUNER2/27/, TUNER3/28/, XCTOL/33/, XFTOL/34/ C/7 C PARAMETER (AFCTOL=31, DECFAC=22, DSTNRM=2, DST0=3, C 1 DSTSAV=18, F=10, FDIF=11, FLSTGD=12, F0=13, C 2 GTSLST=14, GTSTEP=4, INCFAC=23, C 3 LMAX0=35, NREDUC=6, PLSTGD=15, PREDUC=7, C 4 RADFAC=16, RDFCMN=24, RDFCMX=25, C 5 RELDX=17, RFCTOL=32, STPPAR=5, TUNER1=26, C 6 TUNER2=27, TUNER3=28, XCTOL=33, XFTOL=34) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NFC = IV(NFCALL) IV(SWITCH) = 0 IV(RESTOR) = 0 RFAC1 = ONE GOODX = .TRUE. I = IV(IRC) IF (I .GE. 1 .AND. I .LE. 12) 1 GO TO (20,30,10,10,40,360,290,290,290,290,290,140), I IV(IRC) = 13 GO TO 999 C C *** INITIALIZE FOR NEW ITERATION *** C 10 IV(STAGE) = 1 IV(RADINC) = 0 V(FLSTGD) = V(F0) IF (IV(TOOBIG) .EQ. 0) GO TO 90 IV(STAGE) = -1 IV(XIRC) = I GO TO 60 C C *** STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS *** C *** FIRST DECIDE WHICH *** C 20 IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30 C *** OLD MODEL RETAINED, SMALLER RADIUS TRIED *** C *** DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION *** IV(STAGE) = IV(STGLIM) IV(RADINC) = -1 GO TO 90 C C *** A NEW MODEL IS BEING TRIED. DECIDE WHETHER TO KEEP IT. *** C 30 IV(STAGE) = IV(STAGE) + 1 C C *** NOW WE ADD THE POSSIBILTIY THAT STEP WAS RECOMPUTED WITH *** C *** THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP. *** C 40 IF (IV(STAGE) .GT. 0) GO TO 50 C C *** STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG. *** C IF (IV(TOOBIG) .NE. 0) GO TO 60 C C *** RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF. *** C IV(STAGE) = -IV(STAGE) I = IV(XIRC) GO TO (20, 30, 90, 90, 70), I C 50 IF (IV(TOOBIG) .EQ. 0) GO TO 70 C C *** HANDLE OVERSIZE STEP *** C IF (IV(RADINC) .GT. 0) GO TO 80 IV(STAGE) = -IV(STAGE) IV(XIRC) = IV(IRC) C 60 V(RADFAC) = V(DECFAC) IV(RADINC) = IV(RADINC) - 1 IV(IRC) = 5 GO TO 999 C 70 IF (V(F) .LT. V(FLSTGD)) GO TO 90 C C *** THE NEW STEP IS A LOSER. RESTORE OLD MODEL. *** C IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80 IV(MODEL) = IV(MLSTGD) IV(SWITCH) = 1 C C *** RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F). C 80 IF (V(FLSTGD) .GE. V(F0)) GO TO 90 IV(RESTOR) = 1 V(F) = V(FLSTGD) V(PREDUC) = V(PLSTGD) V(GTSTEP) = V(GTSLST) IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV) V(DSTNRM) = V(DSTSAV) NFC = IV(NFGCAL) GOODX = .FALSE. C C C *** COMPUTE RELATIVE CHANGE IN X BY CURRENT STEP *** C 90 RELDX1 = RELDST(P, D, X, X0) C C *** RESTORE X AND STEP IF NECESSARY *** C IF (GOODX) GO TO 105 DO 100 I = 1, P STEP(I) = STLSTG(I) X(I) = X0(I) + STLSTG(I) 100 CONTINUE C 105 V(FDIF) = V(F0) - V(F) IF (V(FDIF) .GT. V(TUNER2) * V(PREDUC)) GO TO 120 C C *** NO (OR ONLY A TRIVIAL) FUNCTION DECREASE C *** -- SO TRY NEW MODEL OR SMALLER RADIUS C V(RELDX) = RELDX1 IF (V(F) .LT. V(F0)) GO TO 110 IV(MLSTGD) = IV(MODEL) V(FLSTGD) = V(F) V(F) = V(F0) CALL VCOPY(P, X, X0) IV(RESTOR) = 1 GO TO 115 110 IV(NFGCAL) = NFC 115 IV(IRC) = 1 IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 130 IV(IRC) = 5 IV(RADINC) = IV(RADINC) - 1 GO TO 130 C C *** NONTRIVIAL FUNCTION DECREASE ACHIEVED *** C 120 IV(NFGCAL) = NFC RFAC1 = ONE IF (GOODX) V(RELDX) = RELDX1 V(DSTSAV) = V(DSTNRM) IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 200 C C *** DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS C *** OR ACCEPT STEP WITH DECREASED RADIUS. C IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 125 C *** CONSIDER SWITCHING MODELS *** IV(IRC) = 2 GO TO 130 C C *** ACCEPT STEP WITH DECREASED RADIUS *** C 125 IV(IRC) = 4 C C *** SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR *** C 130 IV(XIRC) = IV(IRC) EMAX = V(GTSTEP) + V(FDIF) V(RADFAC) = HALF * RFAC1 IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * DMAX1(V(RDFCMN), 1 HALF * V(GTSTEP)/EMAX) C C *** DO FALSE CONVERGENCE TEST *** C 140 IF (V(RELDX) .LE. V(XFTOL)) GO TO 160 IV(IRC) = IV(XIRC) IF (V(F) .LT. V(F0)) GO TO 230 GO TO 300 C 160 IV(IRC) = 12 GO TO 310 C C *** HANDLE GOOD FUNCTION DECREASE *** C 200 IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 260 C C *** INCREASING RADIUS LOOKS WORTHWHILE. SEE IF WE JUST C *** RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP C *** AFTER RECOMPUTING IT WITH A LARGER RADIUS. C IF (IV(RADINC) .LT. 0) GO TO 260 IF (IV(RESTOR) .EQ. 1) GO TO 260 C C *** WE DID NOT. TRY A LONGER STEP UNLESS THIS WAS A NEWTON C *** STEP. C V(RADFAC) = V(RDFCMX) GTS = V(GTSTEP) IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS) 1 V(RADFAC) = DMAX1(V(INCFAC), HALF*GTS/(GTS + V(FDIF))) IV(IRC) = 4 IF (V(STPPAR) .EQ. ZERO) GO TO 300 C *** STEP WAS NOT A NEWTON STEP. RECOMPUTE IT WITH C *** A LARGER RADIUS. IV(IRC) = 5 IV(RADINC) = IV(RADINC) + 1 C C *** SAVE VALUES CORRESPONDING TO GOOD STEP *** C 230 V(FLSTGD) = V(F) IV(MLSTGD) = IV(MODEL) CALL VCOPY(P, STLSTG, STEP) V(DSTSAV) = V(DSTNRM) IV(NFGCAL) = NFC V(PLSTGD) = V(PREDUC) V(GTSLST) = V(GTSTEP) GO TO 300 C C *** ACCEPT STEP WITH RADIUS UNCHANGED *** C 260 V(RADFAC) = ONE IV(IRC) = 3 GO TO 300 C C *** COME HERE FOR A RESTART AFTER CONVERGENCE *** C 290 IV(IRC) = IV(XIRC) IF (V(DSTSAV) .GE. ZERO) GO TO 310 IV(IRC) = 12 GO TO 310 C C *** PERFORM CONVERGENCE TESTS *** C 300 IV(XIRC) = IV(IRC) 310 IF (DABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10 IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999 EMAX = V(RFCTOL) * DABS(V(F0)) IF (V(DSTNRM) .GT. V(LMAX0) .AND. V(PREDUC) .LE. EMAX) 1 IV(IRC) = 11 IF (V(DST0) .LT. ZERO) GO TO 320 I = 0 IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR. 1 (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO)) I = 2 IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL) 1 .AND. GOODX) I = I + 1 IF (I .GT. 0) IV(IRC) = I + 6 C C *** CONSIDER RECOMPUTING STEP OF LENGTH V(LMAX0) FOR SINGULAR C *** CONVERGENCE TEST. C 320 IF (IABS(IV(IRC)-3) .GT. 2 .AND. IV(IRC) .NE. 12) GO TO 999 IF (V(DSTNRM) .GT. V(LMAX0)) GO TO 330 IF (V(PREDUC) .GE. EMAX) GO TO 999 IF (V(DST0) .LE. ZERO) GO TO 340 IF (HALF * V(DST0) .LE. V(LMAX0)) GO TO 999 GO TO 340 330 IF (HALF * V(DSTNRM) .LE. V(LMAX0)) GO TO 999 XMAX = V(LMAX0) / V(DSTNRM) IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAX) GO TO 999 340 IF (V(NREDUC) .LT. ZERO) GO TO 370 C C *** RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST *** C V(GTSLST) = V(GTSTEP) V(DSTSAV) = V(DSTNRM) IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV) V(PLSTGD) = V(PREDUC) IV(IRC) = 6 CALL VCOPY(P, STLSTG, STEP) GO TO 999 C C *** PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC) *** C 360 V(GTSTEP) = V(GTSLST) V(DSTNRM) = DABS(V(DSTSAV)) CALL VCOPY(P, STEP, STLSTG) IV(IRC) = IV(XIRC) IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12 V(NREDUC) = -V(PREDUC) V(PREDUC) = V(PLSTGD) 370 IF (-V(NREDUC) .LE. V(RFCTOL) * DABS(V(F0))) IV(IRC) = 11 C 999 RETURN C C *** LAST CARD OF ASSESS FOLLOWS *** END SUBROUTINE COVCLC(COVIRC, D, IV, J, N, NN, P, R, V, X) COV00010 C C *** COMPUTE COVARIANCE MATRIX FOR NL2ITR (NL2SOL VERSION 2.2) *** C C *** LET K = IABS(IV(COVREQ). FOR K .LE. 2, A FINITE-DIFFERENCE C *** HESSIAN H IS COMPUTED (USING FUNC. AND GRAD. VALUES IF C *** IV(COVREQ) IS NONNEGATIVE, AND USING ONLY FUNC. VALUES IF C *** IV(COVREQ) IS NEGATIVE). FOR SCALE = 2*F(X) / MAX(1, N-P), C *** WHERE 2*F(X) IS THE RESIDUAL SUM OF SQUARES, COVCLC COMPUTES... C *** K = 0 OR 1... SCALE * H**-1 * (J**T * J) * H**-1. C *** K = 2... SCALE * H**-1. C *** K .GE. 3... SCALE * (J**T * J)**-1. C C *** PARAMETER DECLARATIONS *** C INTEGER COVIRC, IV(1), N, NN, P DOUBLE PRECISION D(P), J(NN,P), R(N), V(1), X(P) C DIMENSION IV(*), V(*) C C *** LOCAL VARIABLES *** C LOGICAL HAVEJ INTEGER COV, GP, GSAVE1, G1, HC, HMI, HPI, HPM, I, IPIVI, IPIVK, 1 IP1, IRC, K, KIND, KL, L, M, MM1, MM1O2, PP1O2, QTR1, 2 RD1, STPI, STPM, STP0, WL, W0, W1 DOUBLE PRECISION DEL, HALF, NEGPT5, ONE, T, TWO, WK, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS, MAX0 REAL FLOAT DOUBLE PRECISION DABS, DMAX1 C/ C *** EXTERNAL SUBROUTINES *** C EXTERNAL LINVRT, LITVMU, LIVMUL, LSQRT, LTSQAR, QRFACT, 1 VCOPY, VSCOPY C C LINVRT... INVERT LOWER TRIANGULAR MATRIX. C LITVMU... APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C LIVMUL... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C LSQRT.... COMPUTE CHOLESKY FACTOR OF (LOWER TRINAG. OF) A SYM. MATRIX. C LTSQAR... GIVEN LOWER TRIANG. MATRIX L, COMPUTE (L**T)*L. C QRFACT... COMPUTE QR DECOMPOSITION OF A MATRIX. C VCOPY.... COPY ONE VECTOR TO ANOTHER. C VSCOPY... SET ALL ELEMENTS OF A VECTOR TO A SCALAR. C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVMAT, COVREQ, DELTA, DELTA0, DLTFDC, F, FX, G, H, IERR, 1 IPIVOT, IPIV0, KAGQT, KALM, LMAT, MODE, NFGCAL, QTR, 2 RD, RSAVE, SAVEI, SWITCH, TOOBIG, W, XMSAVE C C/6 DATA HALF/0.5D+0/, NEGPT5/-0.5D+0/, ONE/1.D+0/, TWO/2.D+0/, 1 ZERO/0.D+0/ C/7 C PARAMETER (HALF=0.5D+0, NEGPT5=-0.5D+0, ONE=1.D+0, TWO=2.D+0, C 1 ZERO=0.D+0) C/ C C/6 DATA COVMAT/26/, COVREQ/15/, DELTA/50/, DELTA0/44/, 1 DLTFDC/40/, F/10/, FX/46/, G/28/, H/44/, IERR/32/, 2 IPIVOT/61/, IPIV0/60/, KAGQT/35/, KALM/36/, 3 LMAT/58/, MODE/38/, NFGCAL/7/, QTR/49/, 4 RD/51/, RSAVE/52/, SAVEI/54/, SWITCH/12/, 5 TOOBIG/2/, W/59/, XMSAVE/49/ C/7 C PARAMETER (COVMAT=26, COVREQ=15, DELTA=50, DELTA0=44, C 1 DLTFDC=40, F=10, FX=46, G=28, H=44, IERR=32, C 2 IPIVOT=61, IPIV0=60, KAGQT=35, KALM=36, C 3 LMAT=58, MODE=38, NFGCAL=7, QTR=49, C 4 RD=51, RSAVE=52, SAVEI=54, SWITCH=12, C 5 TOOBIG=2, W=59, XMSAVE=49) C/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C COVIRC = 4 KIND = IV(COVREQ) M = IV(MODE) IF (M .GT. 0) GO TO 10 IV(KAGQT) = -1 IF (IV(KALM) .GT. 0) IV(KALM) = 0 IF (IABS(KIND) .GE. 3) GO TO 300 V(FX) = V(F) K = IV(RSAVE) CALL VCOPY(N, V(K), R) 10 IF (M .GT. P) GO TO 200 IF (KIND .LT. 0) GO TO 100 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND C *** GRADIENT VALUES. C GSAVE1 = IV(W) + P G1 = IV(G) IF (M .GT. 0) GO TO 15 C *** FIRST CALL ON COVCLC. SET GSAVE = G, TAKE FIRST STEP *** CALL VCOPY(P, V(GSAVE1), V(G1)) IV(SWITCH) = IV(NFGCAL) GO TO 80 C 15 DEL = V(DELTA) X(M) = V(XMSAVE) IF (IV(TOOBIG) .EQ. 0) GO TO 30 C C *** HANDLE OVERSIZE V(DELTA) *** C IF (DEL*X(M) .GT. ZERO) GO TO 20 C *** WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT *** IV(COVMAT) = -2 GO TO 190 C C *** TRY SHRINKING V(DELTA) *** 20 DEL = NEGPT5 * DEL GO TO 90 C 30 COV = IV(LMAT) GP = G1 + P - 1 C C *** SET G = (G - GSAVE)/DEL *** C DO 40 I = G1, GP V(I) = (V(I) - V(GSAVE1)) / DEL GSAVE1 = GSAVE1 + 1 40 CONTINUE C C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX *** C K = COV + M*(M-1)/2 L = K + M - 2 IF ( M .EQ. 1) GO TO 60 C C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 *** C DO 50 I = K, L V(I) = HALF * (V(I) + V(G1)) G1 = G1 + 1 50 CONTINUE C C *** ADD H(I,M) = G(I) FOR I = M TO P *** C 60 L = L + 1 DO 70 I = M, P V(L) = V(G1) L = L + I G1 = G1 + 1 70 CONTINUE C 80 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 190 C C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE *** C DEL = V(DELTA0) * DMAX1(ONE/D(M), DABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) 90 X(M) = X(M) + DEL V(DELTA) = DEL COVIRC = 2 GO TO 999 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY. C 100 STP0 = IV(W) + P - 1 MM1 = M - 1 MM1O2 = M*MM1/2 IF (M .GT. 0) GO TO 105 C *** FIRST CALL ON COVCLC. *** IV(SAVEI) = 0 GO TO 180 C 105 I = IV(SAVEI) IF (I .GT. 0) GO TO 160 IF (IV(TOOBIG) .EQ. 0) GO TO 120 C C *** HANDLE OVERSIZE STEP *** C STPM = STP0 + M DEL = V(STPM) IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 110 C *** WE ALREADY TRIED SHRINKING THE STEP, SO QUIT *** IV(COVMAT) = -2 GO TO 999 C C *** TRY SHRINKING THE STEP *** 110 DEL = NEGPT5 * DEL X(M) = X(XMSAVE) + DEL V(STPM) = DEL COVIRC = 1 GO TO 999 C C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) *** C 120 PP1O2 = P * (P-1) / 2 COV = IV(LMAT) HPM = COV + PP1O2 + MM1 V(HPM) = V(F) C C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. *** C HMI = COV + MM1O2 IF (MM1 .EQ. 0) GO TO 140 HPI = COV + PP1O2 DO 130 I = 1, MM1 V(HMI) = V(FX) - (V(F) + V(HPI)) HMI = HMI + 1 HPI = HPI + 1 130 CONTINUE 140 V(HMI) = V(F) - TWO*V(FX) C C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. *** C I = 1 C 150 IV(SAVEI) = I STPI = STP0 + I V(DELTA) = X(I) X(I) = X(I) + V(STPI) IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI) COVIRC = 1 GO TO 999 C 160 X(I) = V(DELTA) IF (IV(TOOBIG) .EQ. 0) GO TO 170 C *** PUNT IN THE EVENT OF AN OVERSIZE STEP *** IV(COVMAT) = -2 GO TO 999 C C *** FINISH COMPUTING H(M,I) *** C 170 STPI = STP0 + I HMI = COV + MM1O2 + I - 1 STPM = STP0 + M V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM)) I = I + 1 IF (I .LE. M) GO TO 150 IV(SAVEI) = 0 X(M) = V(XMSAVE) C 180 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 190 C C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H. C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR. C DEL = V(DLTFDC) * DMAX1(ONE/D(M), DABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) X(M) = X(M) + DEL STPM = STP0 + M V(STPM) = DEL COVIRC = 1 GO TO 999 C C *** RESTORE R, V(F), ETC. *** C 190 K = IV(RSAVE) CALL VCOPY(N, R, V(K)) V(F) = V(FX) IF (KIND .LT. 0) GO TO 200 IV(NFGCAL) = IV(SWITCH) QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) IF (IV(COVMAT) .LT. 0) GO TO 999 COVIRC = 3 GO TO 999 C 200 COV = IV(LMAT) C C *** THE COMPLETE FINITE-DIFF. HESSIAN IS NOW STORED AT V(COV). *** C *** USE IT TO COMPUTE THE REQUESTED COVARIANCE MATRIX. *** C C *** COMPUTE CHOLESKY FACTOR C OF H = C*(C**T) *** C *** AND STORE IT AT V(HC). *** C HC = COV IF (IABS(KIND) .EQ. 2) GO TO 210 HC = IABS(IV(H)) IV(H) = -HC 210 CALL LSQRT(1, P, V(HC), V(COV), IRC) IV(COVMAT) = -1 IF (IRC .NE. 0) GO TO 999 C W1 = IV(W) + P IF (IABS(KIND) .GT. 1) GO TO 350 C C *** COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1 *** C CALL VSCOPY(P*(P+1)/2, V(COV), ZERO) HAVEJ = IV(KALM) .EQ. (-1) C *** HAVEJ = .TRUE. MEANS J IS IN ITS ORIGINAL FORM, WHILE C *** HAVEJ = .FALSE. MEANS QRFACT HAS BEEN APPLIED TO J. C M = P IF (HAVEJ) M = N W0 = W1 - 1 RD1 = IV(RD) DO 290 I = 1, M IF (HAVEJ) GO TO 240 C C *** SET W = IPIVOT * (ROW I OF R MATRIX FROM QRFACT). *** C CALL VSCOPY(P, V(W1), ZERO) IPIVI = IPIV0 + I L = W0 + IV(IPIVI) V(L) = V(RD1) RD1 = RD1 + 1 IF (I .EQ. P) GO TO 260 IP1 = I + 1 DO 230 K = IP1, P IPIVK = IPIV0 + K L = W0 + IV(IPIVK) V(L) = J(I,K) 230 CONTINUE GO TO 260 C C *** SET W = (ROW I OF J). *** C 240 L = W0 DO 250 K = 1, P L = L + 1 V(L) = J(I,K) 250 CONTINUE C C *** SET W = H**-1 * W. *** C 260 CALL LIVMUL(P, V(W1), V(HC), V(W1)) CALL LITVMU(P, V(W1), V(HC), V(W1)) C C *** ADD W * W**T TO COVARIANCE MATRIX. *** C KL = COV DO 280 K = 1, P L = W0 + K WK = V(L) DO 270 L = 1, K WL = W0 + L V(KL) = V(KL) + WK * V(WL) KL = KL + 1 270 CONTINUE 280 CONTINUE 290 CONTINUE GO TO 380 C C *** COVARIANCE = SCALE * (J**T * J)**-1. *** C 300 RD1 = IV(RD) IF (IV(KALM) .NE. (-1)) GO TO 310 C C *** APPLY QRFACT TO J *** C QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) W1 = IV(W) + P CALL QRFACT(NN, N, P, J, V(RD1), IV(IPIVOT), IV(IERR), 0, 1 V(W1)) IV(KALM) = -2 310 IV(COVMAT) = -1 IF (IV(IERR) .NE. 0) GO TO 999 COV = IV(LMAT) HC = IABS(IV(H)) IV(H) = -HC C C *** SET HC = (R MATRIX FROM QRFACT). *** C L = HC DO 340 I = 1, P IF (I .GT. 1) CALL VCOPY(I-1, V(L), J(1,I)) L = L + I - 1 V(L) = V(RD1) L = L + 1 RD1 = RD1 + 1 340 CONTINUE C C *** THE CHOLESKY FACTOR C OF THE UNSCALED INVERSE COVARIANCE MATRIX C *** (OR PERMUTATION THEREOF) IS STORED AT V(HC). C C *** SET C = C**-1. C 350 CALL LINVRT(P, V(HC), V(HC)) C C *** SET C = C**T * C. C CALL LTSQAR(P, V(HC), V(HC)) C IF (HC .EQ. COV) GO TO 380 C C *** C = PERMUTED, UNSCALED COVARIANCE. C *** SET COV = IPIVOT * C * IPIVOT**T. C DO 370 I = 1, P M = IPIV0 + I IPIVI = IV(M) KL = COV-1 + IPIVI*(IPIVI-1)/2 DO 360 K = 1, I M = IPIV0 + K IPIVK = IV(M) L = KL + IPIVK IF (IPIVK .GT. IPIVI) 1 L = L + (IPIVK-IPIVI)*(IPIVK+IPIVI-3)/2 V(L) = V(HC) HC = HC + 1 360 CONTINUE 370 CONTINUE C 380 IV(COVMAT) = COV C C *** APPLY SCALE FACTOR = (RESID. SUM OF SQUARES) / MAX(1,N-P). C T = V(F) / (HALF * FLOAT(MAX0(1,N-P))) K = COV - 1 + P*(P+1)/2 DO 390 I = COV, K 390 V(I) = T * V(I) C 999 RETURN C *** LAST CARD OF COVCLC FOLLOWS *** END SUBROUTINE DFAULT(IV, V) DFA00010 C C *** SUPPLY NL2SOL (VERSION 2.2) DEFAULT VALUES TO IV AND V *** C INTEGER IV(25) DOUBLE PRECISION V(45) C/+ DOUBLE PRECISION DMAX1 C/ EXTERNAL IMDCON, RMDCON INTEGER IMDCON DOUBLE PRECISION RMDCON C DOUBLE PRECISION MACHEP, MEPCRT, ONE, SQTEPS, THREE C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER AFCTOL, COSMIN, COVPRT, COVREQ, DECFAC, DELTA0, DFAC, 1 DINIT, DLTFDC, DLTFDJ, DTYPE, D0INIT, EPSLON, FUZZ, 2 INCFAC, INITS, JTINIT, LMAX0, MXFCAL, MXITER, OUTLEV, 3 PARPRT, PHMNFC, PHMXFC, PRUNIT, RDFCMN, RDFCMX, 4 RFCTOL, RLIMIT, SOLPRT, STATPR, TUNER1, TUNER2, TUNER3, 5 TUNER4, TUNER5, XCTOL, XFTOL, X0PRT C C/6 DATA ONE/1.D+0/, THREE/3.D+0/ C/7 C PARAMETER (ONE=1.D+0, THREE=3.D+0) C/ C C *** IV SUBSCRIPT VALUES *** C C/6 DATA COVPRT/14/, COVREQ/15/, DTYPE/16/, INITS/25/, 1 MXFCAL/17/, MXITER/18/, OUTLEV/19/, 2 PARPRT/20/, PRUNIT/21/, SOLPRT/22/, 3 STATPR/23/, X0PRT/24/ C/7 C PARAMETER (COVPRT=14, COVREQ=15, DTYPE=16, INITS=25, C 1 MXFCAL=17, MXITER=18, OUTLEV=19, C 2 PARPRT=20, PRUNIT=21, SOLPRT=22, C 3 STATPR=23, X0PRT=24) C/ C C *** V SUBSCRIPT VALUES *** C C/6 DATA AFCTOL/31/, COSMIN/43/, DECFAC/22/, 1 DELTA0/44/, DFAC/41/, DINIT/38/, DLTFDC/40/, 2 DLTFDJ/36/, D0INIT/37/, EPSLON/19/, FUZZ/45/, 3 INCFAC/23/, JTINIT/39/, LMAX0/35/, PHMNFC/20/, 4 PHMXFC/21/, RDFCMN/24/, RDFCMX/25/, 5 RFCTOL/32/, RLIMIT/42/, TUNER1/26/, 6 TUNER2/27/, TUNER3/28/, TUNER4/29/, 7 TUNER5/30/, XCTOL/33/, XFTOL/34/ C/7 C PARAMETER (AFCTOL=31, COSMIN=43, DECFAC=22, C 1 DELTA0=44, DFAC=41, DINIT=38, DLTFDC=40, C 2 DLTFDJ=36, D0INIT=37, EPSLON=19, FUZZ=45, C 3 INCFAC=23, JTINIT=39, LMAX0=35, PHMNFC=20, C 4 PHMXFC=21, RDFCMN=24, RDFCMX=25, C 5 RFCTOL=32, RLIMIT=42, TUNER1=26, C 6 TUNER2=27, TUNER3=28, TUNER4=29, C 7 TUNER5=30, XCTOL=33, XFTOL=34) C/ C C----------------------------------------------------------------------- C IV(1) = 12 IV(COVPRT) = 1 IV(COVREQ) = 1 IV(DTYPE) = 1 IV(INITS) = 0 IV(MXFCAL) = 200 IV(MXITER) = 150 IV(OUTLEV) = 1 IV(PARPRT) = 1 IV(PRUNIT) = IMDCON(1) IV(SOLPRT) = 1 IV(STATPR) = 1 IV(X0PRT) = 1 C MACHEP = RMDCON(3) V(AFCTOL) = 1.D-20 IF (MACHEP .GT. 1.D-10) V(AFCTOL) = MACHEP**2 V(COSMIN) = DMAX1(1.D-6, 1.D+2 * MACHEP) V(DECFAC) = 0.5D+0 SQTEPS = RMDCON(4) V(DELTA0) = SQTEPS V(DFAC) = 0.6D+0 V(DINIT) = 0.D+0 MEPCRT = MACHEP ** (ONE/THREE) V(DLTFDC) = MEPCRT V(DLTFDJ) = SQTEPS V(D0INIT) = 1.D+0 V(EPSLON) = 0.1D+0 V(FUZZ) = 1.5D+0 V(INCFAC) = 2.D+0 V(JTINIT) = 1.D-6 V(LMAX0) = 100.D+0 V(PHMNFC) = -0.1D+0 V(PHMXFC) = 0.1D+0 V(RDFCMN) = 0.1D+0 V(RDFCMX) = 4.D+0 V(RFCTOL) = DMAX1(1.D-10, MEPCRT**2) V(RLIMIT) = RMDCON(5) V(TUNER1) = 0.1D+0 V(TUNER2) = 1.D-4 V(TUNER3) = 0.75D+0 V(TUNER4) = 0.5D+0 V(TUNER5) = 0.75D+0 V(XCTOL) = SQTEPS V(XFTOL) = 1.D+2 * MACHEP C 999 RETURN C *** LAST CARD OF DFAULT FOLLOWS *** END DOUBLE PRECISION FUNCTION DOTPRD(P, X, Y) DOT00010 C C *** RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y. *** C INTEGER P DOUBLE PRECISION X(P), Y(P) C INTEGER I DOUBLE PRECISION ONE, SQTETA, T, ZERO C/+ DOUBLE PRECISION DMAX1, DABS C/ EXTERNAL RMDCON DOUBLE PRECISION RMDCON C C *** RMDCON(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH C *** IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT C *** CAN BE SQUARED WITHOUT UNDERFLOWING. C C/6 DATA ONE/1.D+0/, SQTETA/0.D+0/, ZERO/0.D+0/ C/7 C PARAMETER (ONE=1.D+0, ZERO=0.D+0) C DATA SQTETA/0.D+0/ C/ C DOTPRD = ZERO IF (P .LE. 0) GO TO 999 IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2) DO 20 I = 1, P T = DMAX1(DABS(X(I)), DABS(Y(I))) IF (T .GT. ONE) GO TO 10 IF (T .LT. SQTETA) GO TO 20 T = (X(I)/SQTETA)*Y(I) IF (DABS(T) .LT. SQTETA) GO TO 20 10 DOTPRD = DOTPRD + X(I)*Y(I) 20 CONTINUE C 999 RETURN C *** LAST CARD OF DOTPRD FOLLOWS *** END SUBROUTINE DUPDAT(D, IV, J, N, NN, P, V) DUP00010 C C *** UPDATE SCALE VECTOR D FOR NL2ITR (NL2SOL VERSION 2.2) *** C C *** PARAMETER DECLARATIONS *** C INTEGER IV(1), N, NN, P DOUBLE PRECISION D(P), J(NN,P), V(1) C DIMENSION IV(*), V(*) C C *** LOCAL VARIABLES *** C INTEGER D0, I, JTOLI, S1 DOUBLE PRECISION SII, T, VDFAC C C *** CONSTANTS *** DOUBLE PRECISION ZERO C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DMAX1, DSQRT C/ C *** EXTERNAL FUNCTION *** C EXTERNAL V2NORM DOUBLE PRECISION V2NORM C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER DFAC, DTYPE, JTOL0, NITER, S C/6 DATA DFAC/41/, DTYPE/16/, JTOL0/86/, NITER/31/, S/53/ C/7 C PARAMETER (DFAC=41, DTYPE=16, JTOL0=86, NITER=31, S=53) C/ C C/6 DATA ZERO/0.D+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C C----------------------------------------------------------------------- C I = IV(DTYPE) IF (I .EQ. 1) GO TO 20 IF (IV(NITER) .GT. 0) GO TO 999 C 20 VDFAC = V(DFAC) D0 = JTOL0 + P S1 = IV(S) - 1 DO 30 I = 1, P S1 = S1 + I SII = V(S1) T = V2NORM(N, J(1,I)) IF (SII .GT. ZERO) T = DSQRT(T*T + SII) JTOLI = JTOL0 + I D0 = D0 + 1 IF (T .LT. V(JTOLI)) T = DMAX1(V(D0), V(JTOLI)) D(I) = DMAX1(VDFAC*D(I), T) 30 CONTINUE C 999 RETURN C *** LAST CARD OF DUPDAT FOLLOWS *** END SUBROUTINE GQTSTP(D, DIG, DIHDI, KA, L, P, STEP, V, W) GQT00010 C C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE *** C *** (NL2SOL VERSION 2.2) *** C C *** PARAMETER DECLARATIONS *** C INTEGER KA, P DOUBLE PRECISION D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P), 1 W(1) C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED C HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR, C THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF C APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE. IN C OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE C PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP SUCH THAT THE C 2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE C G IS THE GRADIENT, H IS THE HESSIAN, AND D IS A DIAGONAL C SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D. C (GQTSTP ASSUMES DIG = D**-1 * G AND DIHDI = D**-1 * H * D**-1.) C IF G = 0, HOWEVER, STEP = 0 IS RETURNED (EVEN AT A SADDLE POINT). C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE C MATRIX D MENTIONED ABOVE UNDER PURPOSE. C DIG (IN) = THE SCALED GRADIENT VECTOR, D**-1 * G. IF G = 0, THEN C STEP = 0 AND V(STPPAR) = 0 ARE RETURNED. C DIHDI (IN) = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION), C I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E., C IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC. C KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER- C MINE STEP. KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST C ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI) C -- KA IS INITIALIZED TO 0 IN THIS CASE. OUTPUT WITH C KA = 0 (OR V(STPPAR) = 0) MEANS STEP = -(H**-1)*G. C L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS. C P (IN) = NUMBER OF PARAMETERS -- THE HESSIAN IS A P X P MATRIX. C STEP (I/O) = THE STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH 4*P + 6. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR C OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED FOR PSI(STEP). FOR THE C STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE C BY LESS THAN -V(EPSLON)*PSI(STEP). SUGGESTED VALUE = 0.1. C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP) (FOR POS. DEF. C H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE). C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5. C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA C DESCRIBED BELOW UNDER ALGORITHM NOTES. IF H + ALPHA*D**2 C (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER, C THEN V(STPPAR) = -ALPHA. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY STEP AND W ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE WITH C KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO- C NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND C V(RAD0) OF V MUST BE INITIALIZED. TO COMPUTE STEP FROM A SADDLE C POINT (WHERE THE TRUE GRADIENT VANISHES AND H HAS A NEGATIVE C EIGENVALUE), A NONZERO G WITH SMALL COMPONENTS SHOULD BE PASSED. C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST- C SQUARES) PACKAGE (REF. 1), BUT IT COULD BE USED IN SOLVING ANY C UNCONSTRAINED MINIMIZATION PROBLEM. C C *** ALGORITHM NOTES *** C C THE DESIRED G-Q-T STEP (REF. 2, 3, 4) SATISFIES C (H + ALPHA*D**2)*STEP = -G FOR SOME NONNEGATIVE ALPHA SUCH THAT C H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE. ALPHA AND STEP ARE C COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5. C ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN C ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A C SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 6. CASES IN WHICH C H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY C THE TECHNIQUE DISCUSSED IN REF. 2. IN THESE CASES, A STEP OF C (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS C ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP). C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS. C LITVMU - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C LIVMUL - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX. C LSQRT - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.). C LSVMIN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX. C RMDCON - RETURNS MACHINE-DEPENDENT CONSTANTS. C V2NORM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP. C 186-197. C 3. GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966), C MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34, C PP. 541-551. C 4. HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT C SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS C DIV., A.E.R.E. HARWELL, OXON., ENGLAND. C 5. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C 6. VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15, C PP. 719-729. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C LOGICAL RESTRT INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC, 1 J, K, KALIM, K1, LK0, PHIPIN, Q, Q0, UK0, X, X0 DOUBLE PRECISION ALPHAK, AKI, AKK, DELTA, DST, EPSO6, LK, 1 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, 2 ROOT, SI, SK, SW, T, TWOPSI, T1, UK, WI C C *** CONSTANTS *** DOUBLE PRECISION DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE, ONE, 1 P001, SIX, THREE, TWO, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DABS, DMAX1, DMIN1, DSQRT C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL DOTPRD, LITVMU, LIVMUL, LSQRT, LSVMIN, RMDCON, V2NORM DOUBLE PRECISION DOTPRD, LSVMIN, RMDCON, V2NORM C C *** SUBSCRIPTS FOR V *** C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC, 1 PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0 C/6 DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, 1 GTSTEP/4/, NREDUC/6/, PHMNFC/20/, 2 PHMXFC/21/, PREDUC/7/, RADIUS/8/, 3 RAD0/9/, STPPAR/5/ C/7 C PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, C 1 GTSTEP=4, NREDUC=6, PHMNFC=20, C 2 PHMXFC=21, PREDUC=7, RADIUS=8, C 3 RAD0=9, STPPAR=5) C/ C C/6 DATA EPSFAC/50.0D+0/, FOUR/4.0D+0/, HALF/0.5D+0/, 1 KAPPA/2.0D+0/, NEGONE/-1.0D+0/, ONE/1.0D+0/, P001/1.0D-3/, 2 SIX/6.0D+0/, THREE/3.0D+0/, TWO/2.0D+0/, ZERO/0.0D+0/ C/7 C PARAMETER (EPSFAC=50.0D+0, FOUR=4.0D+0, HALF=0.5D+0, C 1 KAPPA=2.0D+0, NEGONE=-1.0D+0, ONE=1.0D+0, P001=1.0D-3, C 2 SIX=6.0D+0, THREE=3.0D+0, TWO=2.0D+0, ZERO=0.0D+0) C SAVE DGXFAC C/ DATA DGXFAC/0.D+0/ C C *** BODY *** C C *** STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX). DGGDMX = P + 1 C *** STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST C *** AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX) C *** AND W(EMIN) RESPECTIVELY. EMAX = DGGDMX + 1 EMIN = EMAX + 1 C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST, C *** AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF. C *** H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN) C *** RESPECTIVELY. LK0 = EMIN + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 C *** STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P). DIAG0 = DSTSAV DIAG = DIAG0 + 1 C *** STORE -D*STEP IN W(Q),...,W(Q0+P). Q0 = DIAG0 + P Q = Q0 + 1 RAD = V(RADIUS) C *** PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF C *** D*STEP. PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD C *** EPSO6 AND PSIFAC ARE USED IN CHECKING FOR THE SPECIAL CASE C *** OF (NEARLY) SINGULAR H + ALPHA*D**2 (SEE REF. 2). PSIFAC = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) * 1 (KAPPA + ONE) + KAPPA + TWO) * RAD**2) C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO EPSO6 = V(EPSLON)/SIX IRC = 0 RESTRT = .FALSE. KALIM = KA + 50 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA .GE. 0) GO TO 310 C C *** FRESH START *** C K = 0 UK = NEGONE KA = 0 KALIM = 50 C C *** STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P) *** C J = 0 DO 20 I = 1, P J = J + I K1 = DIAG0 + I W(K1) = DIHDI(J) 20 CONTINUE C C *** DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI *** C T1 = ZERO J = P * (P + 1) / 2 DO 30 I = 1, J T = DABS(DIHDI(I)) IF (T1 .LT. T) T1 = T 30 CONTINUE W(DGGDMX) = T1 C C *** TRY ALPHA = 0 *** C 40 CALL LSQRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 60 C *** INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, USE THIS C *** ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA. J = IRC*(IRC+1)/2 T = L(J) L(J) = ONE DO 50 I = 1, IRC 50 W(I) = ZERO W(IRC) = ONE CALL LITVMU(IRC, W, L, W) T1 = V2NORM(IRC, W) LK = -T / T1 / T1 V(DST0) = -LK IF (RESTRT) GO TO 210 V(NREDUC) = ZERO GO TO 70 C C *** POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP. *** 60 LK = ZERO CALL LIVMUL(P, W(Q), L, DIG) V(NREDUC) = HALF * DOTPRD(P, W(Q), W(Q)) CALL LITVMU(P, W(Q), L, W(Q)) DST = V2NORM(P, W(Q)) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 280 IF (RESTRT) GO TO 210 C C *** PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND C *** SMALLEST) EIGENVALUES. *** C 70 V(DGNORM) = V2NORM(P, DIG) IF (V(DGNORM) .EQ. ZERO) GO TO 450 K = 0 DO 100 I = 1, P WI = ZERO IF (I .EQ. 1) GO TO 90 IM1 = I - 1 DO 80 J = 1, IM1 K = K + 1 T = DABS(DIHDI(K)) WI = WI + T W(J) = W(J) + T 80 CONTINUE 90 W(I) = WI K = K + 1 100 CONTINUE C C *** (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1) *** C K = 1 T1 = W(DIAG) - W(1) IF (P .LE. 1) GO TO 120 DO 110 I = 2, P J = DIAG0 + I T = W(J) - W(I) IF (T .GE. T1) GO TO 110 T1 = T K = I 110 CONTINUE C 120 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 150 I = 1, P IF (I .EQ. K) GO TO 130 AKI = DABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (AKK - W(J) + SI - AKI) T1 = T1 + DSQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 140 130 INC = I 140 K1 = K1 + INC 150 CONTINUE C W(EMIN) = AKK - T UK = V(DGNORM)/RAD - W(EMIN) C C *** COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE *** C K = 1 T1 = W(DIAG) + W(1) IF (P .LE. 1) GO TO 170 DO 160 I = 2, P J = DIAG0 + I T = W(J) + W(I) IF (T .LE. T1) GO TO 160 T1 = T K = I 160 CONTINUE C 170 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 200 I = 1, P IF (I .EQ. K) GO TO 180 AKI = DABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (W(J) + SI - AKI - AKK) T1 = T1 + DSQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 190 180 INC = I 190 K1 = K1 + INC 200 CONTINUE C W(EMAX) = AKK + T LK = DMAX1(LK, V(DGNORM)/RAD - W(EMAX)) C C *** ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE). WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. ALPHAK = DABS(V(STPPAR)) * V(RAD0)/RAD C IF (IRC .NE. 0) GO TO 210 C C *** COMPUTE L0 FOR POSITIVE DEFINITE H *** C CALL LIVMUL(P, W, L, W(Q)) T = V2NORM(P, W) W(PHIPIN) = DST / T / T LK = DMAX1(LK, PHI*W(PHIPIN)) C C *** SAFEGUARD ALPHAK AND ADD ALPHAK*I TO (D**-1)*H*(D**-1) *** C 210 KA = KA + 1 IF (-V(DST0) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK) 1 ALPHAK = UK * DMAX1(P001, DSQRT(LK/UK)) K = 0 DO 220 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) + ALPHAK 220 CONTINUE C C *** TRY COMPUTING CHOLESKY DECOMPOSITION *** C CALL LSQRT(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 250 C C *** (D**-1)*H*(D**-1) + ALPHAK*I IS INDEFINITE -- OVERESTIMATE C *** SMALLEST EIGENVALUE FOR USE IN UPDATING LK *** C J = (IRC*(IRC+1))/2 T = L(J) L(J) = ONE DO 230 I = 1, IRC 230 W(I) = ZERO W(IRC) = ONE CALL LITVMU(IRC, W, L, W) T1 = V2NORM(IRC, W) LK = ALPHAK - T/T1/T1 V(DST0) = -LK GO TO 210 C C *** ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE. C *** COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE. *** C 250 CALL LIVMUL(P, W(Q), L, DIG) CALL LITVMU(P, W(Q), L, W(Q)) DST = V2NORM(P, W(Q)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 290 IF (PHI .EQ. OLDPHI) GO TO 290 OLDPHI = PHI IF (PHI .GT. ZERO) GO TO 260 C *** CHECK FOR THE SPECIAL CASE OF H + ALPHA*D**2 (NEARLY) C *** SINGULAR. DELTA IS .GE. THE SMALLEST EIGENVALUE OF C *** (D**-1)*H*(D**-1) + ALPHAK*I. IF (V(DST0) .GT. ZERO) GO TO 260 DELTA = ALPHAK + V(DST0) TWOPSI = ALPHAK*DST*DST + DOTPRD(P, DIG, W(Q)) IF (DELTA .LT. PSIFAC*TWOPSI) GO TO 270 C C *** UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK *** C 260 IF (KA .GE. KALIM) GO TO 290 CALL LIVMUL(P, W, L, W(Q)) T1 = V2NORM(P, W) C *** THE FOLLOWING DMIN1 IS NECESSARY BECAUSE OF RESTARTS *** IF (PHI .LT. ZERO) UK = DMIN1(UK, ALPHAK) ALPHAK = ALPHAK + (PHI/T1) * (DST/T1) * (DST/RAD) LK = DMAX1(LK, ALPHAK) GO TO 210 C C *** DECIDE HOW TO HANDLE (NEARLY) SINGULAR H + ALPHA*D**2 *** C C *** IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC. 270 IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * RMDCON(3) C C *** NOW DECIDE. *** IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 350 C *** DELTA IS SO SMALL WE CANNOT HANDLE THE SPECIAL CASE IN C *** THE AVAILABLE ARITHMETIC. ACCEPT STEP AS IT IS. GO TO 290 C C *** ACCEPTABLE STEP ON FIRST TRY *** C 280 ALPHAK = ZERO C C *** SUCCESSFUL STEP IN GENERAL. COMPUTE STEP = -(D**-1)*Q *** C 290 DO 300 I = 1, P J = Q0 + I STEP(I) = -W(J)/D(I) 300 CONTINUE V(GTSTEP) = -DOTPRD(P, DIG, W(Q)) V(PREDUC) = HALF * (DABS(ALPHAK)*DST*DST - V(GTSTEP)) GO TO 430 C C C *** RESTART WITH NEW RADIUS *** C 310 IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 330 C C *** PREPARE TO RETURN NEWTON STEP *** C RESTRT = .TRUE. KA = KA + 1 K = 0 DO 320 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) 320 CONTINUE UK = NEGONE GO TO 40 C 330 IF (KA .EQ. 0) GO TO 60 C DST = W(DSTSAV) ALPHAK = DABS(V(STPPAR)) PHI = DST - RAD T = V(DGNORM)/RAD IF (RAD .GT. V(RAD0)) GO TO 340 C C *** SMALLER RADIUS *** UK = T - W(EMIN) LK = ZERO IF (ALPHAK .GT. ZERO) LK = W(LK0) LK = DMAX1(LK, T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 260 C C *** BIGGER RADIUS *** 340 UK = T - W(EMIN) IF (ALPHAK .GT. ZERO) UK = DMIN1(UK, W(UK0)) LK = DMAX1(ZERO, -V(DST0), T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 260 C C *** HANDLE (NEARLY) SINGULAR H + ALPHA*D**2 *** C C *** NEGATE ALPHAK TO INDICATE SPECIAL CASE *** 350 ALPHAK = -ALPHAK C *** ALLOCATE STORAGE FOR SCRATCH VECTOR X *** X0 = Q0 + P X = X0 + 1 C C *** USE INVERSE POWER METHOD WITH START FROM LSVMIN TO OBTAIN C *** APPROXIMATE EIGENVECTOR CORRESPONDING TO SMALLEST EIGENVALUE C *** OF (D**-1)*H*(D**-1). C DELTA = KAPPA*DELTA T = LSVMIN(P, L, W(X), W) C K = 0 C *** NORMALIZE W *** 360 DO 370 I = 1, P 370 W(I) = T*W(I) C *** COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W. CALL LITVMU(P, W, L, W) T1 = ONE/V2NORM(P, W) T = T1*T IF (T .LE. DELTA) GO TO 390 IF (K .GT. 30) GO TO 290 K = K + 1 C *** START NEXT INV. POWER ITER. BY STORING NORMALIZED W IN X. DO 380 I = 1, P J = X0 + I W(J) = T1*W(I) 380 CONTINUE C *** COMPUTE W = (L**-1)*X. CALL LIVMUL(P, W, L, W(X)) T = ONE/V2NORM(P, W) GO TO 360 C 390 DO 400 I = 1, P 400 W(I) = T1*W(I) C C *** NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND C *** T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W. C SW = DOTPRD(P, W(Q), W) T1 = (RAD + DST) * (RAD - DST) ROOT = DSQRT(SW*SW + T1) IF (SW .LT. ZERO) ROOT = -ROOT SI = T1 / (SW + ROOT) C *** ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A C *** FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3. V(PREDUC) = HALF*TWOPSI T1 = ZERO T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T*DOTPRD(P,W(X),W))) IF (T .LT. EPSO6*TWOPSI) GO TO 410 V(PREDUC) = V(PREDUC) + T DST = RAD T1 = -SI 410 DO 420 I = 1, P J = Q0 + I W(J) = T1*W(I) - W(J) STEP(I) = W(J) / D(I) 420 CONTINUE V(GTSTEP) = DOTPRD(P, DIG, W(Q)) C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 430 V(DSTNRM) = DST V(STPPAR) = ALPHAK W(LK0) = LK W(UK0) = UK V(RAD0) = RAD W(DSTSAV) = DST C C *** RESTORE DIAGONAL OF DIHDI *** C J = 0 DO 440 I = 1, P J = J + I K = DIAG0 + I DIHDI(J) = W(K) 440 CONTINUE GO TO 999 C C *** SPECIAL CASE -- G = 0 *** C 450 V(STPPAR) = ZERO V(PREDUC) = ZERO V(DSTNRM) = ZERO V(GTSTEP) = ZERO DO 460 I = 1, P 460 STEP(I) = ZERO C 999 RETURN C C *** LAST CARD OF GQTSTP FOLLOWS *** END SUBROUTINE ITSMRY(D, IV, P, V, X) ITS00010 C C *** PRINT NL2SOL (VERSION 2.2) ITERATION SUMMARY *** C C *** PARAMETER DECLARATIONS *** C INTEGER IV(1), P DOUBLE PRECISION D(P), V(1), X(P) C DIMENSION IV(*), V(*) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER COV1, G1, I, II, IV1, I1, J, M, NF, NG, OL, PU C/6 REAL MODEL1(6), MODEL2(6) C/7 C CHARACTER*4 MODEL1(6), MODEL2(6) C/ DOUBLE PRECISION NRELDF, OLDF, PRELDF, RELDF, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS C/ C *** NO EXTERNAL FUNCTIONS OR SUBROUTINES *** C C *** SUBSCRIPTS FOR IV AND V *** C INTEGER COVMAT, COVPRT, COVREQ, DSTNRM, F, FDIF, F0, G, 1 NEEDHD, NFCALL, NFCOV, NGCOV, NGCALL, NITER, NREDUC, 2 OUTLEV, PREDUC, PRNTIT, PRUNIT, RELDX, SIZE, SOLPRT, 3 STATPR, STPPAR, SUSED, X0PRT C C *** IV SUBSCRIPT VALUES *** C C/6 DATA COVMAT/26/, COVPRT/14/, G/28/, COVREQ/15/, 1 NEEDHD/39/, NFCALL/6/, NFCOV/40/, NGCOV/41/, 2 NGCALL/30/, NITER/31/, OUTLEV/19/, PRNTIT/48/, 3 PRUNIT/21/, SOLPRT/22/, STATPR/23/, SUSED/57/, 4 X0PRT/24/ C/7 C PARAMETER (COVMAT=26, COVPRT=14, G=28, COVREQ=15, C 1 NEEDHD=39, NFCALL=6, NFCOV=40, NGCOV=41, C 2 NGCALL=30, NITER=31, OUTLEV=19, PRNTIT=48, C 3 PRUNIT=21, SOLPRT=22, STATPR=23, SUSED=57, C 4 X0PRT=24) C/ C C *** V SUBSCRIPT VALUES *** C C/6 DATA DSTNRM/2/, F/10/, F0/13/, FDIF/11/, NREDUC/6/, 1 PREDUC/7/, RELDX/17/, SIZE/47/, STPPAR/5/ C/7 C PARAMETER (DSTNRM=2, F=10, F0=13, FDIF=11, NREDUC=6, C 1 PREDUC=7, RELDX=17, SIZE=47, STPPAR=5) C/ C C/6 DATA ZERO/0.D+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C/6 DATA MODEL1(1)/4H /, MODEL1(2)/4H /, MODEL1(3)/4H /, 1 MODEL1(4)/4H /, MODEL1(5)/4H G /, MODEL1(6)/4H S /, 2 MODEL2(1)/4H G /, MODEL2(2)/4H S /, MODEL2(3)/4HG-S /, 3 MODEL2(4)/4HS-G /, MODEL2(5)/4H-S-G/, MODEL2(6)/4H-G-S/ C/7 C DATA MODEL1/' ',' ',' ',' ',' G ',' S '/, C 1 MODEL2/' G ',' S ','G-S ','S-G ','-S-G','-G-S'/ C/ C C----------------------------------------------------------------------- C PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 IV1 = IV(1) OL = IV(OUTLEV) IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 140 IF (OL .EQ. 0) GO TO 20 IF (IV1 .GE. 12) GO TO 20 IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 20 IF (IV1 .GT. 2) GO TO 10 IV(PRNTIT) = IV(PRNTIT) + 1 IF (IV(PRNTIT) .LT. IABS(OL)) GO TO 999 10 NF = IV(NFCALL) - IABS(IV(NFCOV)) IV(PRNTIT) = 0 RELDF = ZERO PRELDF = ZERO OLDF = V(F0) IF (OLDF .LE. ZERO) GO TO 12 RELDF = V(FDIF) / OLDF PRELDF = V(PREDUC) / OLDF 12 IF (OL .GT. 0) GO TO 15 C C *** PRINT SHORT SUMMARY LINE *** C IF (IV(NEEDHD) .EQ. 1) WRITE(PU, 1010) 1010 FORMAT(12H0 IT NF,6X,1HF,8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX) IV(NEEDHD) = 0 WRITE(PU,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX) GO TO 20 C C *** PRINT LONG SUMMARY LINE *** C 15 IF (IV(NEEDHD) .EQ. 1) WRITE(PU,1015) 1015 FORMAT(12H0 IT NF,6X,1HF,8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX, 1 4X,15HMODEL STPPAR,6X,4HSIZE,6X,6HD*STEP,5X,7HNPRELDF) IV(NEEDHD) = 0 M = IV(SUSED) NRELDF = ZERO IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF WRITE(PU,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), 1 MODEL1(M), MODEL2(M), V(STPPAR), V(SIZE), 2 V(DSTNRM), NRELDF 1017 FORMAT(1X,I5,I6,4D11.3,A3,A4,4D11.3) C 20 GO TO (999,999,30,35,40,45,50,60,70,80,90,150,110,120,130), IV1 C 30 WRITE(PU,1030) 1030 FORMAT(26H0***** X-CONVERGENCE *****) GO TO 180 C 35 WRITE(PU,1035) 1035 FORMAT(42H0***** RELATIVE FUNCTION CONVERGENCE *****) GO TO 180 C 40 WRITE(PU,1040) 1040 FORMAT(49H0***** X- AND RELATIVE FUNCTION CONVERGENCE *****) GO TO 180 C 45 WRITE(PU,1045) 1045 FORMAT(42H0***** ABSOLUTE FUNCTION CONVERGENCE *****) GO TO 180 C 50 WRITE(PU,1050) 1050 FORMAT(33H0***** SINGULAR CONVERGENCE *****) GO TO 180 C 60 WRITE(PU,1060) 1060 FORMAT(30H0***** FALSE CONVERGENCE *****) GO TO 180 C 70 WRITE(PU,1070) 1070 FORMAT(38H0***** FUNCTION EVALUATION LIMIT *****) GO TO 180 C 80 WRITE(PU,1080) 1080 FORMAT(28H0***** ITERATION LIMIT *****) GO TO 180 C 90 WRITE(PU,1090) 1090 FORMAT(18H0***** STOPX *****) GO TO 180 C 110 WRITE(PU,1100) 1100 FORMAT(45H0***** INITIAL SUM OF SQUARES OVERFLOWS *****) C GO TO 150 C 120 WRITE(PU,1120) 1120 FORMAT(37H0***** BAD PARAMETERS TO ASSESS *****) GO TO 999 C 130 WRITE(PU,1130) 1130 FORMAT(36H0***** J COULD NOT BE COMPUTED *****) IF (IV(NITER) .GT. 0) GO TO 190 GO TO 150 C 140 WRITE(PU,1140) IV1 1140 FORMAT(14H0***** IV(1) =,I5,6H *****) GO TO 999 C C *** INITIAL CALL ON ITSMRY *** C 150 IF (IV(X0PRT) .NE. 0) WRITE(PU,1150) (I, X(I), D(I), I = 1, P) 1150 FORMAT(23H0 I INITIAL X(I),7X,4HD(I)//(1X,I5,D17.6,D14.3)) IF (IV1 .GE. 13) GO TO 999 IV(NEEDHD) = 0 IV(PRNTIT) = 0 IF (OL .EQ. 0) GO TO 999 IF (OL .LT. 0) WRITE(PU,1010) IF (OL .GT. 0) WRITE(PU,1015) WRITE(PU,1160) V(F) 1160 FORMAT(12H0 0 1,D11.3,11X,D11.3) GO TO 999 C C *** PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION *** C 180 IV(NEEDHD) = 1 IF (IV(STATPR) .EQ. 0) GO TO 190 OLDF = V(F0) PRELDF = ZERO NRELDF = ZERO IF (OLDF .LE. ZERO) GO TO 185 PRELDF = V(PREDUC) / OLDF NRELDF = V(NREDUC) / OLDF 185 NF = IV(NFCALL) - IV(NFCOV) NG = IV(NGCALL) - IV(NGCOV) WRITE(PU,1180) V(F), V(RELDX), NF, NG, PRELDF, NRELDF 1180 FORMAT(9H0FUNCTION,D17.6,8H RELDX,D20.6/12H FUNC. EVALS, 1 I8,9X,11HGRAD. EVALS,I8/7H PRELDF,D19.6,3X,7HNPRELDF,D18.6) C IF (IV(NFCOV) .GT. 0) WRITE(PU,1185) IV(NFCOV) 1185 FORMAT(1H0,I4,34H EXTRA FUNC. EVALS FOR COVARIANCE.) IF (IV(NGCOV) .GT. 0) WRITE(PU,1186) IV(NGCOV) 1186 FORMAT(1X,I4,34H EXTRA GRAD. EVALS FOR COVARIANCE.) C 190 IF (IV(SOLPRT) .EQ. 0) GO TO 210 IV(NEEDHD) = 1 G1 = IV(G) WRITE(PU,1190) 1190 FORMAT(22H0 I FINAL X(I),8X,4HD(I),10X,4HG(I)/) DO 200 I = 1, P WRITE(PU,1200) I, X(I), D(I), V(G1) G1 = G1 + 1 200 CONTINUE 1200 FORMAT(1X,I5,D17.6,2D14.3) C 210 IF (IV(COVPRT) .EQ. 0) GO TO 999 COV1 = IV(COVMAT) IV(NEEDHD) = 1 IF (COV1) 220, 230, 240 220 IF (-1 .EQ. COV1) WRITE(PU,1220) 1220 FORMAT(43H0++++++ INDEFINITE COVARIANCE MATRIX ++++++) IF (-2 .EQ. COV1) WRITE(PU,1225) 1225 FORMAT(52H0++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++) GO TO 999 C 230 WRITE(PU,1230) 1230 FORMAT(45H0++++++ COVARIANCE MATRIX NOT COMPUTED ++++++) GO TO 999 C 240 I = IABS(IV(COVREQ)) IF (I .LE. 1) WRITE(PU,1241) 1241 FORMAT(48H0COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/) IF (I .EQ. 2) WRITE(PU,1242) 1242 FORMAT(27H0COVARIANCE = SCALE * H**-1/) IF (I .GE. 3) WRITE(PU,1243) 1243 FORMAT(36H0COVARIANCE = SCALE * (J**T * J)**-1/) II = COV1 - 1 IF (OL .LE. 0) GO TO 260 DO 250 I = 1, P I1 = II + 1 II = II + I WRITE(PU,1250) I, (V(J), J = I1, II) 250 CONTINUE 1250 FORMAT(4H ROW,I3,2X,9D12.4/(9X,9D12.4)) GO TO 999 C 260 DO 270 I = 1, P I1 = II + 1 II = II + I WRITE(PU,1270) I, (V(J), J = I1, II) 270 CONTINUE 1270 FORMAT(4H ROW,I3,2X,5D12.4/(9X,5D12.4)) C 999 RETURN C *** LAST CARD OF ITSMRY FOLLOWS *** END SUBROUTINE LINVRT(N, LIN, L) LIN00010 C C *** COMPUTE LIN = L**-1, BOTH N X N LOWER TRIANG. STORED *** C *** COMPACTLY BY ROWS. LIN AND L MAY SHARE THE SAME STORAGE. *** C C *** PARAMETERS *** C INTEGER N DOUBLE PRECISION L(1), LIN(1) C DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1 DOUBLE PRECISION ONE, T, ZERO C/6 DATA ONE/1.D+0/, ZERO/0.D+0/ C/7 C PARAMETER (ONE=1.D+0, ZERO=0.D+0) C/ C C *** BODY *** C NP1 = N + 1 J0 = N*(NP1)/2 DO 30 II = 1, N I = NP1 - II LIN(J0) = ONE/L(J0) IF (I .LE. 1) GO TO 999 J1 = J0 IM1 = I - 1 DO 20 JJ = 1, IM1 T = ZERO J0 = J1 K0 = J1 - JJ DO 10 K = 1, JJ T = T - L(K0)*LIN(J0) J0 = J0 - 1 K0 = K0 + K - I 10 CONTINUE LIN(J0) = T/L(K0) 20 CONTINUE J0 = J0 - 1 30 CONTINUE 999 RETURN C *** LAST CARD OF LINVRT FOLLOWS *** END SUBROUTINE LITVMU(N, X, L, Y) LIT00010 C C *** SOLVE (L**T)*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N DOUBLE PRECISION X(N), L(1), Y(N) INTEGER I, II, IJ, IM1, I0, J, NP1 DOUBLE PRECISION XI, ZERO C/6 DATA ZERO/0.D+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C DO 10 I = 1, N 10 X(I) = Y(I) NP1 = N + 1 I0 = N*(N+1)/2 DO 30 II = 1, N I = NP1 - II XI = X(I)/L(I0) X(I) = XI IF (I .LE. 1) GO TO 999 I0 = I0 - I IF (XI .EQ. ZERO) GO TO 30 IM1 = I - 1 DO 20 J = 1, IM1 IJ = I0 + J X(J) = X(J) - XI*L(IJ) 20 CONTINUE 30 CONTINUE 999 RETURN C *** LAST CARD OF LITVMU FOLLOWS *** END SUBROUTINE LIVMUL(N, X, L, Y) LIV00010 C C *** SOLVE L*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C INTEGER N DOUBLE PRECISION X(N), L(1), Y(N) EXTERNAL DOTPRD DOUBLE PRECISION DOTPRD INTEGER I, J, K DOUBLE PRECISION T, ZERO C/6 DATA ZERO/0.D+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C DO 10 K = 1, N IF (Y(K) .NE. ZERO) GO TO 20 X(K) = ZERO 10 CONTINUE GO TO 999 20 J = K*(K+1)/2 X(K) = Y(K) / L(J) IF (K .GE. N) GO TO 999 K = K + 1 DO 30 I = K, N T = DOTPRD(I-1, L(J+1), X) J = J + I X(I) = (Y(I) - T)/L(J) 30 CONTINUE 999 RETURN C *** LAST CARD OF LIVMUL FOLLOWS *** END SUBROUTINE LMSTEP(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W) LMS00010 C C *** COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE ** C *** NL2SOL VERSION 2.2. *** C C *** PARAMETER DECLARATIONS *** C INTEGER IERR, KA, P INTEGER IPIVOT(P) DOUBLE PRECISION D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1) C DIMENSION W(P*(P+5)/2 + 4) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN C MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING C RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG- C MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE- C TECHNIQUE. C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR. C G (IN) = THE GRADIENT VECTOR (J**T)*R. C IERR (I/O) = RETURN CODE FROM QRFACT OR QRFGS -- 0 MEANS R HAS C FULL RANK. C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR QRFGS, WHICH COMPUTE C QR DECOMPOSITIONS WITH COLUMN PIVOTING. C KA (I/O). KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON C LMSTEP FOR THE CURRENT R AND QTR. ON OUTPUT KA CON- C TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE C STEP. KA = 0 MEANS A GAUSS-NEWTON STEP. C P (IN) = NUMBER OF PARAMETERS. C QTR (IN) = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR. C R (IN) = THE R MATRIX, STORED COMPACTLY BY COLUMNS. C STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (I/O) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS C TWONORM(R - J*STEP)**2. (SEE ALGORITHM NOTES BELOW.) C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C FOR A GAUSS-NEWTON STEP. C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C BY THE STEP RETURNED. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL C CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS). C C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY MANY PARAMETERS ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE C WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P, C QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0). C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST- C SQUARES) PACKAGE (REF. 1). C C *** ALGORITHM NOTES *** C C THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN C REFS. 2 AND 4. FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60- C 62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER. C A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS) C IS SUFFICIENTLY LARGE. IN THIS CASE THE STEP RETURNED IS SUCH C THAT TWONORM(R)**2 - TWONORM(R - J*STEP)**2 DIFFERS FROM ITS C OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE, C WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL. (SEE C REF. 2 FOR MORE DETAILS.) C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS. C LITVMU - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C LIVMUL - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C VCOPY - COPIES ONE VECTOR TO ANOTHER. C V2NORM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH. C SOFTWARE, VOL. 7, NO. 3. C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS, C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP. C 186-197. C 3. LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES C PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J. C 4. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN, 1 PP1O2, RES, RES0, RMAT, RMAT0, UK0 DOUBLE PRECISION A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2, 1 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, 2 SI, SJ, SQRTAK, T, TWOPSI, UK, WL C C *** CONSTANTS *** DOUBLE PRECISION DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE, 1 TTOL, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER IABS DOUBLE PRECISION DABS, DMAX1, DMIN1, DSQRT C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL DOTPRD, LITVMU, LIVMUL, VCOPY, V2NORM DOUBLE PRECISION DOTPRD, V2NORM C C *** SUBSCRIPTS FOR V *** C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC, 1 PHMXFC, PREDUC, RADIUS, RAD0, STPPAR C/6 DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, 1 GTSTEP/4/, NREDUC/6/, PHMNFC/20/, 2 PHMXFC/21/, PREDUC/7/, RADIUS/8/, 3 RAD0/9/, STPPAR/5/ C/7 C PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, C 1 GTSTEP=4, NREDUC=6, PHMNFC=20, C 2 PHMXFC=21, PREDUC=7, RADIUS=8, C 3 RAD0=9, STPPAR=5) C/ C C/6 DATA DFAC/256.D+0/, EIGHT/8.D+0/, HALF/0.5D+0/, NEGONE/-1.D+0/, 1 ONE/1.D+0/, P001/1.D-3/, THREE/3.D+0/, TTOL/2.5D+0/, 2 ZERO/0.D+0/ C/7 C PARAMETER (DFAC=256.D+0, EIGHT=8.D+0, HALF=0.5D+0, NEGONE=-1.D+0, C 1 ONE=1.D+0, P001=1.D-3, THREE=3.D+0, TTOL=2.5D+0, C 2 ZERO=0.D+0) C/ C C *** BODY *** C C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK, C *** THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J) C *** AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0), C *** W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY. LK0 = P + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 RMAT0 = DSTSAV C *** A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS C *** STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL C *** VECTOR IS STORED IN W STARTING AT W(RES). THE LOOPS BELOW C *** THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER C *** WORK ON THESE COPIES. RMAT = RMAT0 + 1 PP1O2 = P * (P + 1) / 2 RES0 = PP1O2 + RMAT0 RES = RES0 + 1 RAD = V(RADIUS) IF (RAD .GT. ZERO) 1 PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2) PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD C *** DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS C *** REPRESENTATION OF THE UPDATED QR DECOMPOSITION. DTOL = ONE/DFAC DFACSQ = DFAC*DFAC C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO LK = ZERO UK = ZERO KALIM = KA + 12 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA) 10, 20, 370 C C *** FRESH START -- COMPUTE V(NREDUC) *** C 10 KA = 0 KALIM = 12 K = P IF (IERR .NE. 0) K = IABS(IERR) - 1 V(NREDUC) = HALF*DOTPRD(K, QTR, QTR) C C *** SET UP TO TRY INITIAL GAUSS-NEWTON STEP *** C 20 V(DST0) = NEGONE IF (IERR .NE. 0) GO TO 90 C C *** COMPUTE GAUSS-NEWTON STEP *** C C *** NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN C *** R(1), R(2), R(3), ... IT IS THE TRANSPOSE OF A C *** LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE C *** TREAT IT AS SUCH WHEN USING LITVMU AND LIVMUL. CALL LITVMU(P, W, R, QTR) C *** TEMPORARILY STORE PERMUTED -D*STEP IN STEP. DO 60 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*W(I) 60 CONTINUE DST = V2NORM(P, STEP) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 410 C *** IF THIS IS A RESTART, GO TO 110 *** IF (KA .GT. 0) GO TO 110 C C *** GAUSS-NEWTON STEP WAS UNACCEPTABLE. COMPUTE L0 *** C DO 70 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*(STEP(I)/DST) 70 CONTINUE CALL LIVMUL(P, STEP, R, STEP) T = ONE / V2NORM(P, STEP) W(PHIPIN) = (T/DST)*T LK = PHI*W(PHIPIN) C C *** COMPUTE U0 *** C 90 DO 100 I = 1, P 100 W(I) = G(I)/D(I) V(DGNORM) = V2NORM(P, W) UK = V(DGNORM)/RAD IF (UK .LE. ZERO) GO TO 390 C C *** ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER. WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. ALPHAK = DABS(V(STPPAR)) * V(RAD0)/RAD C C C *** TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES *** C 110 KA = KA + 1 CALL VCOPY(PP1O2, W(RMAT), R) CALL VCOPY(P, W(RES), QTR) C C *** SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR. *** C IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK) 1 ALPHAK = UK * DMAX1(P001, DSQRT(LK/UK)) SQRTAK = DSQRT(ALPHAK) DO 120 I = 1, P 120 W(I) = ONE C C *** ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS. *** C DO 270 I = 1, P C *** GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D. C *** (USE STEP TO STORE TEMPORARY ROW) *** L = I*(I+1)/2 + RMAT0 WL = W(L) D2 = ONE D1 = W(I) J1 = IPIVOT(I) ADI = SQRTAK*D(J1) IF (ADI .GE. DABS(WL)) GO TO 150 130 A = ADI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 150 W(I) = D1/T D2 = D2/T W(L) = T*WL A = -A DO 140 J1 = I, P L = L + J1 STEP(J1) = A*W(L) 140 CONTINUE GO TO 170 C 150 B = WL/ADI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 130 W(I) = D2/T D2 = D1/T W(L) = T*ADI DO 160 J1 = I, P L = L + J1 WL = W(L) STEP(J1) = -WL W(L) = A*WL 160 CONTINUE C 170 IF (I .EQ. P) GO TO 280 C C *** NOW USE GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW *** C IP1 = I + 1 DO 260 I1 = IP1, P L = I1*(I1+1)/2 + RMAT0 WL = W(L) SI = STEP(I1-1) D1 = W(I1) C C *** RESCALE ROW I1 IF NECESSARY *** C IF (D1 .GE. DTOL) GO TO 190 D1 = D1*DFACSQ WL = WL/DFAC K = L DO 180 J1 = I1, P K = K + J1 W(K) = W(K)/DFAC 180 CONTINUE C C *** USE GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW C 190 IF (DABS(SI) .GT. DABS(WL)) GO TO 220 IF (SI .EQ. ZERO) GO TO 260 200 A = SI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 220 W(L) = T*WL W(I1) = D1/T D2 = D2/T DO 210 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = WL + B*SJ STEP(J1) = SJ - A*WL 210 CONTINUE GO TO 240 C 220 B = WL/SI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 200 W(I1) = D2/T D2 = D1/T W(L) = T*SI DO 230 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = A*WL + SJ STEP(J1) = B*SJ - WL 230 CONTINUE C C *** RESCALE TEMP. ROW IF NECESSARY *** C 240 IF (D2 .GE. DTOL) GO TO 260 D2 = D2*DFACSQ DO 250 K = I1, P 250 STEP(K) = STEP(K)/DFAC 260 CONTINUE 270 CONTINUE C C *** COMPUTE STEP *** C 280 CALL LITVMU(P, W(RES), W(RMAT), W(RES)) C *** RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES) *** DO 290 I = 1, P J1 = IPIVOT(I) K = RES0 + I T = W(K) STEP(J1) = -T W(K) = T*D(J1) 290 CONTINUE DST = V2NORM(P, W(RES)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430 IF (OLDPHI .EQ. PHI) GO TO 430 OLDPHI = PHI C C *** CHECK FOR (AND HANDLE) SPECIAL CASE *** C IF (PHI .GT. ZERO) GO TO 310 IF (KA .GE. KALIM) GO TO 430 TWOPSI = ALPHAK*DST*DST - DOTPRD(P, STEP, G) IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310 V(STPPAR) = -ALPHAK GO TO 440 C C *** UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN *** C 300 IF (PHI .LT. ZERO) UK = DMIN1(UK, ALPHAK) GO TO 320 310 IF (PHI .LT. ZERO) UK = ALPHAK 320 DO 330 I = 1, P J1 = IPIVOT(I) K = RES0 + I STEP(I) = D(J1) * (W(K)/DST) 330 CONTINUE CALL LIVMUL(P, STEP, W(RMAT), STEP) DO 340 I = 1, P 340 STEP(I) = STEP(I) / DSQRT(W(I)) T = ONE / V2NORM(P, STEP) ALPHAK = ALPHAK + T*PHI*T/RAD LK = DMAX1(LK, ALPHAK) GO TO 110 C C *** RESTART *** C 370 LK = W(LK0) UK = W(UK0) IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20 ALPHAK = DABS(V(STPPAR)) DST = W(DSTSAV) PHI = DST - RAD T = V(DGNORM)/RAD IF (RAD .GT. V(RAD0)) GO TO 380 C C *** SMALLER RADIUS *** UK = T IF (ALPHAK .LE. ZERO) LK = ZERO IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** BIGGER RADIUS *** 380 IF (ALPHAK .LE. ZERO .OR. UK .GT. T) UK = T LK = ZERO IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR) *** C 390 V(STPPAR) = ZERO DST = ZERO LK = ZERO UK = ZERO V(GTSTEP) = ZERO V(PREDUC) = ZERO DO 400 I = 1, P 400 STEP(I) = ZERO GO TO 450 C C *** ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W *** C 410 ALPHAK = ZERO DO 420 I = 1, P J1 = IPIVOT(I) STEP(J1) = -W(I) 420 CONTINUE C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 430 V(STPPAR) = ALPHAK 440 V(GTSTEP) = DOTPRD(P, STEP, G) V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP)) 450 V(DSTNRM) = DST W(DSTSAV) = DST W(LK0) = LK W(UK0) = UK V(RAD0) = RAD C 999 RETURN C C *** LAST CARD OF LMSTEP FOLLOWS *** END SUBROUTINE LSQRT(N1, N, L, A, IRC) LSQ00010 C C *** COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR L OF C *** A = L*(L**T), WHERE L AND THE LOWER TRIANGLE OF A ARE BOTH C *** STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE). C *** IRC = 0 MEANS ALL WENT WELL. IRC = J MEANS THE LEADING C *** PRINCIPAL J X J SUBMATRIX OF A IS NOT POSITIVE DEFINITE -- C *** AND L(J*(J+1)/2) CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL. C C *** PARAMETERS *** C INTEGER N1, N, IRC DOUBLE PRECISION L(1), A(1) C DIMENSION L(N*(N+1)/2), A(N*(N+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K DOUBLE PRECISION T, TD, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DSQRT C/ C/6 DATA ZERO/0.D+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C C *** BODY *** C I0 = N1 * (N1 - 1) / 2 DO 50 I = N1, N TD = ZERO IF (I .EQ. 1) GO TO 40 J0 = 0 IM1 = I - 1 DO 30 J = 1, IM1 T = ZERO IF (J .EQ. 1) GO TO 20 JM1 = J - 1 DO 10 K = 1, JM1 IK = I0 + K JK = J0 + K T = T + L(IK)*L(JK) 10 CONTINUE 20 IJ = I0 + J J0 = J0 + J T = (A(IJ) - T) / L(J0) L(IJ) = T TD = TD + T*T 30 CONTINUE 40 I0 = I0 + I T = A(I0) - TD IF (T .LE. ZERO) GO TO 60 L(I0) = DSQRT(T) 50 CONTINUE C IRC = 0 GO TO 999 C 60 L(I0) = T IRC = I C 999 RETURN C C *** LAST CARD OF LSQRT *** END DOUBLE PRECISION FUNCTION LSVMIN(P, L, X, Y) LSV00010 C C *** ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L C C *** PARAMETER DECLARATIONS *** C INTEGER P DOUBLE PRECISION L(1), X(P), Y(P) C DIMENSION L(P*(P+1)/2) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L. C C *** PARAMETER DESCRIPTION *** C C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX. C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E. C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC. C X (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED C APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE C SMALLEST SINGULAR VALUE. THIS APPROXIMATION MAY BE VERY C CRUDE. IF LSVMIN RETURNS ZERO, THEN SOME COMPONENTS OF X C ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES. C Y (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN C UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND- C ING TO THE SMALLEST SINGULAR VALUE. THIS APPROXIMATION C MAY BE CRUDE. IF LSVMIN RETURNS ZERO, THEN Y RETAINS ITS C INPUT VALUE. THE CALLER MAY PASS THE SAME VECTOR FOR X C AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER- C WRITES X (FOR NONZERO LSVMIN RETURNS). C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THERE ARE NO USAGE RESTRICTIONS. C C *** ALGORITHM NOTES *** C C THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT C LSVMIN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L C (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE C LARGEST. THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED C IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE C (2) AND (3). C C *** SUBROUTINES AND FUNCTIONS CALLED *** C C V2NORM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR. C C *** REFERENCES *** C C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977), C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY. C C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW, C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV. C C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2 C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS. C C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18, C PP. 586-593. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PPLUS1 DOUBLE PRECISION B, PSJ, SMINUS, SPLUS, T, XMINUS, XPLUS C C *** CONSTANTS *** C DOUBLE PRECISION HALF, ONE, R9973, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ INTEGER MOD REAL FLOAT DOUBLE PRECISION DABS C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL V2NORM DOUBLE PRECISION V2NORM C C/6 DATA HALF/0.5D+0/, ONE/1.D+0/, R9973/9973.D+0/, ZERO/0.D+0/ C/7 C PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0) C SAVE IX C/ DATA IX/2/ C C *** BODY *** C C *** FIRST CHECK WHETHER TO RETURN LSVMIN = 0 AND INITIALIZE X *** C II = 0 DO 10 I = 1, P X(I) = ZERO II = II + I IF (L(II) .EQ. ZERO) GO TO 300 10 CONTINUE IF (MOD(IX, 9973) .EQ. 0) IX = 2 PPLUS1 = P + 1 C C *** SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE. C C DO J = P TO 1 BY -1... DO 100 JJJ = 1, P J = PPLUS1 - JJJ C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I. IX = MOD(3432*IX, 9973) B = HALF*(ONE + FLOAT(IX)/R9973) XPLUS = (B - X(J)) XMINUS = (-B - X(J)) SPLUS = DABS(XPLUS) SMINUS = DABS(XMINUS) JM1 = J - 1 J0 = J*JM1/2 JJ = J0 + J XPLUS = XPLUS/L(JJ) XMINUS = XMINUS/L(JJ) IF (JM1 .EQ. 0) GO TO 30 DO 20 I = 1, JM1 JI = J0 + I SPLUS = SPLUS + DABS(X(I) + L(JI)*XPLUS) SMINUS = SMINUS + DABS(X(I) + L(JI)*XMINUS) 20 CONTINUE 30 IF (SMINUS .GT. SPLUS) XPLUS = XMINUS X(J) = XPLUS C *** UPDATE PARTIAL SUMS *** IF (JM1 .EQ. 0) GO TO 100 DO 40 I = 1, JM1 JI = J0 + I X(I) = X(I) + L(JI)*XPLUS 40 CONTINUE 100 CONTINUE C C *** NORMALIZE X *** C T = ONE/V2NORM(P, X) DO 110 I = 1, P 110 X(I) = T*X(I) C C *** SOLVE L*Y = X AND RETURN SVMIN = 1/TWONORM(Y) *** C DO 200 J = 1, P PSJ = ZERO JM1 = J - 1 J0 = J*JM1/2 IF (JM1 .EQ. 0) GO TO 130 DO 120 I = 1, JM1 JI = J0 + I PSJ = PSJ + L(JI)*Y(I) 120 CONTINUE 130 JJ = J0 + J Y(J) = (X(J) - PSJ)/L(JJ) 200 CONTINUE C LSVMIN = ONE/V2NORM(P, Y) GO TO 999 C 300 LSVMIN = ZERO 999 RETURN C *** LAST CARD OF LSVMIN FOLLOWS *** END SUBROUTINE LTSQAR(N, A, L) LTS00010 C C *** SET A TO LOWER TRIANGLE OF (L**T) * L *** C C *** L = N X N LOWER TRIANG. MATRIX STORED ROWWISE. *** C *** A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L. *** C INTEGER N DOUBLE PRECISION A(1), L(1) C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2) C INTEGER I, II, IIM1, I1, J, K, M DOUBLE PRECISION LII, LJ C II = 0 DO 50 I = 1, N I1 = II + 1 II = II + I M = 1 IF (I .EQ. 1) GO TO 30 IIM1 = II - 1 DO 20 J = I1, IIM1 LJ = L(J) DO 10 K = I1, J A(M) = A(M) + LJ*L(K) M = M + 1 10 CONTINUE 20 CONTINUE 30 LII = L(II) DO 40 J = I1, II 40 A(J) = LII * L(J) 50 CONTINUE C 999 RETURN C *** LAST CARD OF LTSQAR FOLLOWS *** END SUBROUTINE PARCHK(IV, N, NN, P, V) PAR00010 C C *** CHECK NL2SOL (VERSION 2.2) PARAMETERS, PRINT CHANGED VALUES *** C INTEGER IV(1), N, NN, P DOUBLE PRECISION V(1) C DIMENSION IV(*), V(*) C EXTERNAL DFAULT, RMDCON, VCOPY DOUBLE PRECISION RMDCON C DFAULT -- SUPPLIES DFAULT PARAMETER VALUES. C RMDCON -- RETURNS MACHINE-DEPENDENT CONSTANTS. C VCOPY -- COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C INTEGER I, IV1, JTOLP, K, L, M, NVDFLT, PU C/6 REAL CNGD(3), DFLT(3), VN(2,27), WHICH(3) C/7 C CHARACTER*4 CNGD(3), DFLT(3), VN(2,27), WHICH(3) C/ DOUBLE PRECISION BIG, MACHEP, TINY, VK, VM(27), VX(27), ZERO C C *** IV AND V SUBSCRIPTS *** C INTEGER DTYPE, DTYPE0, D0INIT, EPSLON, INITS, JTINIT, JTOL0, 1 JTOL1, OLDN, OLDNN, OLDP, PARPRT, PARSV1, PRUNIT C C/6 DATA NVDFLT/27/, ZERO/0.D+0/ C/7 C PARAMETER (NVDFLT=27, ZERO=0.D+0) C/ C C/6 DATA DTYPE/16/, DTYPE0/29/, D0INIT/37/, EPSLON/19/, 1 INITS/25/, JTINIT/39/, JTOL0/86/, JTOL1/87/, 2 OLDN/45/, OLDNN/46/, OLDP/47/, PARPRT/20/, 3 PARSV1/51/, PRUNIT/21/ C/7 C PARAMETER (DTYPE=16, DTYPE0=29, D0INIT=37, EPSLON=19, C 1 INITS=25, JTINIT=39, JTOL0=86, JTOL1=87, C 2 OLDN=45, OLDNN=46, OLDP=47, PARPRT=20, C 3 PARSV1=51, PRUNIT=21) C SAVE BIG, TINY C/ C DATA BIG/0.D+0/, TINY/1.D+0/ C/6 DATA VN(1,1),VN(2,1)/4HEPSL,4HON../ DATA VN(1,2),VN(2,2)/4HPHMN,4HFC../ DATA VN(1,3),VN(2,3)/4HPHMX,4HFC../ DATA VN(1,4),VN(2,4)/4HDECF,4HAC../ DATA VN(1,5),VN(2,5)/4HINCF,4HAC../ DATA VN(1,6),VN(2,6)/4HRDFC,4HMN../ DATA VN(1,7),VN(2,7)/4HRDFC,4HMX../ DATA VN(1,8),VN(2,8)/4HTUNE,4HR1../ DATA VN(1,9),VN(2,9)/4HTUNE,4HR2../ DATA VN(1,10),VN(2,10)/4HTUNE,4HR3../ DATA VN(1,11),VN(2,11)/4HTUNE,4HR4../ DATA VN(1,12),VN(2,12)/4HTUNE,4HR5../ DATA VN(1,13),VN(2,13)/4HAFCT,4HOL../ DATA VN(1,14),VN(2,14)/4HRFCT,4HOL../ DATA VN(1,15),VN(2,15)/4HXCTO,4HL.../ DATA VN(1,16),VN(2,16)/4HXFTO,4HL.../ DATA VN(1,17),VN(2,17)/4HLMAX,4H0.../ DATA VN(1,18),VN(2,18)/4HDLTF,4HDJ../ DATA VN(1,19),VN(2,19)/4HD0IN,4HIT../ DATA VN(1,20),VN(2,20)/4HDINI,4HT.../ DATA VN(1,21),VN(2,21)/4HJTIN,4HIT../ DATA VN(1,22),VN(2,22)/4HDLTF,4HDC../ DATA VN(1,23),VN(2,23)/4HDFAC,4H..../ DATA VN(1,24),VN(2,24)/4HRLIM,4HIT../ DATA VN(1,25),VN(2,25)/4HCOSM,4HIN../ DATA VN(1,26),VN(2,26)/4HDELT,4HA0../ DATA VN(1,27),VN(2,27)/4HFUZZ,4H..../ C/7 C DATA VN(1,1),VN(2,1)/'EPSL','ON..'/ C DATA VN(1,2),VN(2,2)/'PHMN','FC..'/ C DATA VN(1,3),VN(2,3)/'PHMX','FC..'/ C DATA VN(1,4),VN(2,4)/'DECF','AC..'/ C DATA VN(1,5),VN(2,5)/'INCF','AC..'/ C DATA VN(1,6),VN(2,6)/'RDFC','MN..'/ C DATA VN(1,7),VN(2,7)/'RDFC','MX..'/ C DATA VN(1,8),VN(2,8)/'TUNE','R1..'/ C DATA VN(1,9),VN(2,9)/'TUNE','R2..'/ C DATA VN(1,10),VN(2,10)/'TUNE','R3..'/ C DATA VN(1,11),VN(2,11)/'TUNE','R4..'/ C DATA VN(1,12),VN(2,12)/'TUNE','R5..'/ C DATA VN(1,13),VN(2,13)/'AFCT','OL..'/ C DATA VN(1,14),VN(2,14)/'RFCT','OL..'/ C DATA VN(1,15),VN(2,15)/'XCTO','L...'/ C DATA VN(1,16),VN(2,16)/'XFTO','L...'/ C DATA VN(1,17),VN(2,17)/'LMAX','0...'/ C DATA VN(1,18),VN(2,18)/'DLTF','DJ..'/ C DATA VN(1,19),VN(2,19)/'D0IN','IT..'/ C DATA VN(1,20),VN(2,20)/'DINI','T...'/ C DATA VN(1,21),VN(2,21)/'JTIN','IT..'/ C DATA VN(1,22),VN(2,22)/'DLTF','DC..'/ C DATA VN(1,23),VN(2,23)/'DFAC','....'/ C DATA VN(1,24),VN(2,24)/'RLIM','IT..'/ C DATA VN(1,25),VN(2,25)/'COSM','IN..'/ C DATA VN(1,26),VN(2,26)/'DELT','A0..'/ C DATA VN(1,27),VN(2,27)/'FUZZ','....'/ C/ C DATA VM(1)/1.0D-3/, VM(2)/-0.99D+0/, VM(3)/1.0D-3/, VM(4)/1.0D-2/, 1 VM(5)/1.2D+0/, VM(6)/1.D-2/, VM(7)/1.2D+0/, VM(8)/0.D+0/, 2 VM(9)/0.D+0/, VM(10)/1.D-3/, VM(11)/-1.D+0/, VM(15)/0.D+0/, 3 VM(16)/0.D+0/, VM(19)/0.D+0/, VM(20)/-10.D+0/, VM(21)/0.D+0/, 4 VM(23)/0.D+0/, VM(24)/1.D+10/, VM(27)/1.01D+0/ DATA VX(1)/0.9D+0/, VX(2)/-1.D-3/, VX(3)/1.D+1/, VX(4)/0.8D+0/, 1 VX(5)/1.D+2/, VX(6)/0.8D+0/, VX(7)/1.D+2/, VX(8)/0.5D+0/, 2 VX(9)/0.5D+0/, VX(10)/1.D+0/, VX(11)/1.D+0/, VX(14)/0.1D+0/, 3 VX(15)/1.D+0/, VX(16)/1.D+0/, VX(18)/1.D+0/, VX(22)/1.D+0/, 4 VX(23)/1.D+0/, VX(25)/1.D+0/, VX(26)/1.D+0/, VX(27)/1.D+2/ C C/6 DATA CNGD(1),CNGD(2),CNGD(3)/4H---C,4HHANG,4HED V/, 1 DFLT(1),DFLT(2),DFLT(3)/4HNOND,4HEFAU,4HLT V/ C/7 C DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/, C 1 DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/ C/ C C....................................................................... C IF (IV(1) .EQ. 0) CALL DFAULT(IV, V) PU = IV(PRUNIT) IV1 = IV(1) IF (IV1 .NE. 12) GO TO 30 IF (NN .GE. N .AND. N .GE. P .AND. P .GE. 1) GO TO 20 IV(1) = 16 IF (PU .NE. 0) WRITE(PU,10) NN, N, P 10 FORMAT(30H0///// BAD NN, N, OR P... NN =,I5,5H, N =,I5, 1 5H, P =,I5) GO TO 999 20 K = IV(21) CALL DFAULT(IV(21), V(33)) IV(21) = K IV(DTYPE0) = IV(DTYPE+20) IV(OLDN) = N IV(OLDNN) = NN IV(OLDP) = P WHICH(1) = DFLT(1) WHICH(2) = DFLT(2) WHICH(3) = DFLT(3) GO TO 80 30 IF (N .EQ. IV(OLDN) .AND. NN .EQ. IV(OLDNN) .AND. P .EQ. IV(OLDP)) 1 GO TO 50 IV(1) = 17 IF (PU .NE. 0) WRITE(PU,40) IV(OLDNN), IV(OLDN), IV(OLDP), NN, 1 N, P 40 FORMAT(30H0///// (NN,N,P) CHANGED FROM (,I5,1H,,I5,1H,,I3, 1 6H) TO (,I5,1H,,I5,1H,,I3,2H).) GO TO 999 C 50 IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 70 IV(1) = 50 IF (PU .NE. 0) WRITE(PU,60) IV1 60 FORMAT(15H0///// IV(1) =,I5,28H SHOULD BE BETWEEN 0 AND 12.) GO TO 999 C 70 WHICH(1) = CNGD(1) WHICH(2) = CNGD(2) WHICH(3) = CNGD(3) C 80 IF (BIG .GT. TINY) GO TO 90 TINY = RMDCON(1) MACHEP = RMDCON(3) BIG = RMDCON(6) VM(12) = MACHEP VX(12) = BIG VM(13) = TINY VX(13) = BIG VM(14) = MACHEP VM(17) = TINY VX(17) = BIG VM(18) = MACHEP VX(19) = BIG VX(20) = BIG VX(21) = BIG VM(22) = MACHEP VX(24) = RMDCON(5) VM(25) = MACHEP VM(26) = MACHEP 90 M = 0 IF (IV(INITS) .GE. 0 .AND. IV(INITS) .LE. 2) GO TO 110 M = 18 IF (PU .NE. 0) WRITE(PU,100) IV(INITS) 100 FORMAT(25H0///// INITS... IV(25) =,I4,20H SHOULD BE BETWEEN 0, 1 7H AND 2.) 110 K = EPSLON DO 140 I = 1, NVDFLT VK = V(K) IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 130 M = K IF (PU .NE. 0) WRITE(PU,120) VN(1,I), VN(2,I), K, VK, 1 VM(I), VX(I) 120 FORMAT(8H0///// ,2A4,5H.. V(,I2,3H) =,D11.3,7H SHOULD, 1 11H BE BETWEEN,D11.3,4H AND,D11.3) 130 K = K + 1 140 CONTINUE C IF (IV1 .EQ. 12 .AND. V(JTINIT) .GT. ZERO) GO TO 170 C C *** CHECK JTOL VALUES *** C JTOLP = JTOL0 + P DO 160 I = JTOL1, JTOLP IF (V(I) .GT. ZERO) GO TO 160 K = I - JTOL0 IF (PU .NE. 0) WRITE(PU,150) K, I, V(I) 150 FORMAT(12H0///// JTOL(,I3,6H) = V(,I3,3H) =,D11.3, 1 20H SHOULD BE POSITIVE.) M = I 160 CONTINUE C 170 IF (M .EQ. 0) GO TO 180 IV(1) = M GO TO 999 C 180 IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999 IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. 0) GO TO 200 M = 1 WRITE(PU,190) IV(INITS) 190 FORMAT(22H0NONDEFAULT VALUES..../20H INITS..... IV(25) =,I3) 200 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 210 IF (M .EQ. 0) WRITE(PU,215) WHICH M = 1 WRITE(PU,205) IV(DTYPE) 205 FORMAT(20H DTYPE..... IV(16) =,I3) 210 K = EPSLON L = PARSV1 DO 240 I = 1, NVDFLT IF (V(K) .EQ. V(L)) GO TO 230 IF (M .EQ. 0) WRITE(PU,215) WHICH 215 FORMAT(1H0,3A4,9HALUES..../) M = 1 WRITE(PU,220) VN(1,I), VN(2,I), K, V(K) 220 FORMAT(1X,2A4,5H.. V(,I2,3H) =,D15.7) 230 K = K + 1 L = L + 1 240 CONTINUE IV(DTYPE0) = IV(DTYPE) CALL VCOPY(NVDFLT, V(PARSV1), V(EPSLON)) IF (IV1 .NE. 12) GO TO 999 IF (V(JTINIT) .GT. ZERO) GO TO 260 JTOLP = JTOL0 + P WRITE(PU,250) (V(I), I = JTOL1, JTOLP) 250 FORMAT(24H0(INITIAL) JTOL ARRAY.../(1X,6D12.3)) 260 IF (V(D0INIT) .GT. ZERO) GO TO 999 K = JTOL1 + P L = K + P - 1 WRITE(PU,270) (V(I), I = K, L) 270 FORMAT(22H0(INITIAL) D0 ARRAY.../1X,6D12.3) C 999 RETURN C *** LAST CARD OF PARCHK FOLLOWS *** END SUBROUTINE QAPPLY(NN, N, P, J, R, IERR) QAP00010 C *****PARAMETERS. INTEGER NN, N, P, IERR DOUBLE PRECISION J(NN,P), R(N) C C .................................................................. C .................................................................. C C *****PURPOSE. C THIS SUBROUTINE APPLIES TO R THE ORTHOGONAL TRANSFORMATIONS C STORED IN J BY QRFACT C C *****PARAMETER DESCRIPTION. C ON INPUT. C C NN IS THE ROW DIMENSION OF THE MATRIX J AS DECLARED IN C THE CALLING PROGRAM DIMENSION STATEMENT C C N IS THE NUMBER OF ROWS OF J AND THE SIZE OF THE VECTOR R C C P IS THE NUMBER OF COLUMNS OF J AND THE SIZE OF SIGMA C C J CONTAINS ON AND BELOW ITS DIAGONAL THE COLUMN VECTORS C U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS C IDENT - U*U.TRANSPOSE C C R IS THE RIGHT HAND SIDE VECTOR TO WHICH THE ORTHOGONAL C TRANSFORMATIONS WILL BE APPLIED C C IERR IF NON-ZERO INDICATES THAT NOT ALL THE TRANSFORMATIONS C WERE SUCCESSFULLY DETERMINED AND ONLY THE FIRST C ABS(IERR) - 1 TRANSFORMATIONS WILL BE USED C C ON OUTPUT. C C R HAS BEEN OVERWRITTEN BY ITS TRANSFORMED IMAGE C C *****APPLICATION AND USAGE RESTRICTIONS. C NONE C C *****ALGORITHM NOTES. C THE VECTORS U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS C ARE NORMALIZED SO THAT THEIR 2-NORM SQUARED IS 2. THE USE OF C THESE TRANSFORMATIONS HERE IS IN THE SPIRIT OF (1). C C *****SUBROUTINES AND FUNCTIONS CALLED. C C DOTPRD - FUNCTION, RETURNS THE INNER PRODUCT OF VECTORS C C *****REFERENCES. C (1) BUSINGER, P. A., AND GOLUB, G. H. (1965), LINEAR LEAST SQUARES C SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7, C PP. 269-276. C C *****HISTORY. C DESIGNED BY DAVID M. GAY, CODED BY STEPHEN C. PETERS (WINTER 1977) C C *****GENERAL. C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C .................................................................. C .................................................................. C C *****LOCAL VARIABLES. INTEGER I, K, L, NL1 DOUBLE PRECISION T C *****INTRINSIC FUNCTIONS. C/+ INTEGER IABS C/ C *****FUNCTIONS. EXTERNAL DOTPRD DOUBLE PRECISION DOTPRD C K = P IF (IERR .NE. 0) K = IABS(IERR) - 1 IF ( K .EQ. 0) GO TO 999 C DO 20 L = 1, K NL1 = N - L + 1 T = -DOTPRD(NL1, J(L,L), R(L)) C DO 10 I = L, N 10 R(I) = R(I) + T*J(I,L) 20 CONTINUE 999 RETURN C .... LAST CARD OF QAPPLY ......................................... END SUBROUTINE QRFACT(NM,M,N,QR,ALPHA,IPIVOT,IERR,NOPIVK,SUM) QRF00010 C C *** COMPUTE THE QR DECOMPOSITION OF THE MATRIX STORED IN QR *** C C *****PARAMETERS. INTEGER NM,M,N,IPIVOT(N),IERR,NOPIVK DOUBLE PRECISION QR(NM,N),ALPHA(N),SUM(N) C *****LOCAL VARIABLES. INTEGER I,J,JBAR,K,K1,MINUM,MK1 DOUBLE PRECISION ALPHAK,BETA,QRKK,QRKMAX,SIGMA,TEMP,UFETA,RKTOL, 1 RKTOL1,SUMJ C *****FUNCTIONS. C/+ INTEGER MIN0 DOUBLE PRECISION DABS,DSQRT C/ EXTERNAL DOTPRD, RMDCON, VAXPY, VSCOPY, V2NORM DOUBLE PRECISION DOTPRD, RMDCON, V2NORM C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS. C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS. C VAXPY... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V2NORM... RETURNS THE 2-NORM OF A VECTOR. C C *****CONSTANTS. DOUBLE PRECISION ONE, P01, P99, ZERO C/6 DATA ONE/1.0D+0/, P01/0.01D+0/, P99/0.99D+0/, ZERO/0.0D+0/ C/7 C PARAMETER (ONE=1.0D+0, P01=0.01D+0, P99=0.99D+0, ZERO=0.0D+0) C SAVE RKTOL, UFETA C/ C C C .................................................................. C .................................................................. C C C *****PURPOSE. C C THIS SUBROUTINE DOES A QR-DECOMPOSITION ON THE M X N MATRIX QR, C WITH AN OPTIONALLY MODIFIED COLUMN PIVOTING, AND RETURNS THE C UPPER TRIANGULAR R-MATRIX, AS WELL AS THE ORTHOGONAL VECTORS C USED IN THE TRANSFORMATIONS. C C *****PARAMETER DESCRIPTION. C ON INPUT. C C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C M MUST BE SET TO THE NUMBER OF ROWS IN THE MATRIX. C C N MUST BE SET TO THE NUMBER OF COLUMNS IN THE MATRIX. C C QR CONTAINS THE REAL RECTANGULAR MATRIX TO BE DECOMPOSED. C C NOPIVK IS USED TO CONTROL PIVOTTING. COLUMNS 1 THROUGH C NOPIVK WILL REMAIN FIXED IN POSITION. C C SUM IS USED FOR TEMPORARY STORAGE FOR THE SUBROUTINE. C C ON OUTPUT. C C QR CONTAINS THE NON-DIAGONAL ELEMENTS OF THE R-MATRIX C IN THE STRICT UPPER TRIANGLE. THE VECTORS U, WHICH C DEFINE THE HOUSEHOLDER TRANSFORMATIONS I - U*U-TRANSP, C ARE IN THE COLUMNS OF THE LOWER TRIANGLE. THESE VECTORS U C ARE SCALED SO THAT THE SQUARE OF THEIR 2-NORM IS 2.0. C C ALPHA CONTAINS THE DIAGONAL ELEMENTS OF THE R-MATRIX. C C IPIVOT REFLECTS THE COLUMN PIVOTING PERFORMED ON THE INPUT C MATRIX TO ACCOMPLISH THE DECOMPOSITION. THE J-TH C ELEMENT OF IPIVOT GIVES THE COLUMN OF THE ORIGINAL C MATRIX WHICH WAS PIVOTED INTO COLUMN J DURING THE C DECOMPOSITION. C C IERR IS SET TO. C 0 FOR NORMAL RETURN, C K IF NO NON-ZERO PIVOT COULD BE FOUND FOR THE K-TH C TRANSFORMATION, OR C -K FOR AN ERROR EXIT ON THE K-TH THANSFORMATION. C IF AN ERROR EXIT WAS TAKEN, THE FIRST (K - 1) C TRANSFORMATIONS ARE CORRECT. C C C *****APPLICATIONS AND USAGE RESTRICTIONS. C THIS MAY BE USED WHEN SOLVING LINEAR LEAST-SQUARES PROBLEMS -- C SEE SUBROUTINE QR1 OF ROSEPACK. IT IS CALLED FOR THIS PURPOSE C BY LLSQST IN THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE. C C *****ALGORITHM NOTES. C THIS VERSION OF QRFACT TRIES TO ELIMINATE THE OCCURRENCE OF C UNDERFLOWS DURING THE ACCUMULATION OF INNER PRODUCTS. RKTOL1 C IS CHOSEN BELOW SO AS TO INSURE THAT DISCARDED TERMS HAVE NO C EFFECT ON THE COMPUTED TWO-NORMS. C C ADAPTED FROM THE ALGOL ROUTINE SOLVE (1). C C *****REFERENCES. C (1) BUSINGER,P. AND GOLUB,G.H., LINEAR LEAST SQUARES C SOLUTIONS BY HOUSHOLDER TRANSFORMATIONS, IN WILKINSON,J.H. C AND REINSCH,C.(EDS.), HANDBOOK FOR AUTOMATIC COMPUTATION, C VOLUME II. LINEAR ALGEBRA, SPRINGER-VERLAG, 111-118 (1971). C PREPUBLISHED IN NUMER.MATH. 7, 269-276 (1965). C C *****HISTORY. C THIS AMOUNTS TO THE SUBROUTINE QR1 OF ROSEPACK WITH RKTOL1 USED C IN PLACE OF RKTOL BELOW, WITH V2NORM USED TO INITIALIZE (AND C SOMETIMES UPDATE) THE SUM ARRAY, AND WITH CALLS ON DOTPRD AND C VAXPY IN PLACE OF SOME LOOPS. C C *****GENERAL. C C DEVELOPMENT OF THIS PROGRAM SUPPORTED IN PART BY C NATIONAL SCIENCE FOUNDATION GRANT GJ-1154X3 AND C NATIONAL SCIENCE FOUNDATION GRANT DCR75-08802 C TO NATIONAL BUREAU OF ECONOMIC RESEARCH, INC. C C C C .................................................................. C .................................................................. C C C .......... UFETA IS THE SMALLEST POSITIVE FLOATING POINT NUMBER C S.T. UFETA AND -UFETA CAN BOTH BE REPRESENTED. C C .......... RKTOL IS THE SQUARE ROOT OF THE RELATIVE PRECISION C OF FLOATING POINT ARITHMETIC (MACHEP). DATA RKTOL/0.D+0/, UFETA/0.D+0/ C *****BODY OF PROGRAM. IF (UFETA .GT. ZERO) GO TO 10 UFETA = RMDCON(1) RKTOL = RMDCON(4) 10 IERR = 0 RKTOL1 = P01 * RKTOL C DO 20 J=1,N SUM(J) = V2NORM(M, QR(1,J)) IPIVOT(J) = J 20 CONTINUE C MINUM = MIN0(M,N) C DO 120 K=1,MINUM MK1 = M - K + 1 C ..........K-TH HOUSEHOLDER TRANSFORMATION.......... SIGMA = ZERO JBAR = 0 C ..........FIND LARGEST COLUMN SUM.......... IF (K .LE. NOPIVK) GO TO 50 DO 30 J=K,N IF (SIGMA .GE. SUM(J)) GO TO 30 SIGMA = SUM(J) JBAR = J 30 CONTINUE C IF (JBAR .EQ. 0) GO TO 220 IF (JBAR .EQ. K) GO TO 50 C ..........COLUMN INTERCHANGE.......... I = IPIVOT(K) IPIVOT(K) = IPIVOT(JBAR) IPIVOT(JBAR) = I SUM(JBAR) = SUM(K) SUM(K) = SIGMA C DO 40 I=1,M SIGMA = QR(I,K) QR(I,K) = QR(I,JBAR) QR(I,JBAR) = SIGMA 40 CONTINUE C ..........END OF COLUMN INTERCHANGE.......... 50 CONTINUE C .......... SECOND INNER PRODUCT .......... QRKMAX = ZERO C DO 60 I=K,M IF (DABS( QR(I,K) ) .GT. QRKMAX) QRKMAX = DABS( QR(I,K) ) 60 CONTINUE C IF (QRKMAX .LT. UFETA) GO TO 210 ALPHAK = V2NORM(MK1, QR(K,K)) / QRKMAX SIGMA = ALPHAK**2 C C .......... END SECOND INNER PRODUCT .......... QRKK = QR(K,K) IF (QRKK .GE. ZERO) ALPHAK = -ALPHAK ALPHA(K) = ALPHAK * QRKMAX BETA = QRKMAX * DSQRT(SIGMA - (QRKK*ALPHAK/QRKMAX) ) QR(K,K) = QRKK - ALPHA(K) DO 65 I=K,M 65 QR(I,K) = QR(I,K) / BETA K1 = K + 1 IF (K1 .GT. N) GO TO 120 C DO 110 J = K1, N TEMP = -DOTPRD(MK1, QR(K,K), QR(K,J)) C C *** SET QR(I,J) = QR(I,J) + TEMP*QR(I,K), I = K,...,M. C CALL VAXPY(MK1, QR(K,J), TEMP, QR(K,K), QR(K,J)) C IF (K1 .GT. M) GO TO 110 SUMJ = SUM(J) IF (SUMJ .LT. UFETA) GO TO 110 TEMP = DABS(QR(K,J)/SUMJ) IF (TEMP .LT. RKTOL1) GO TO 110 IF (TEMP .GE. P99) GO TO 90 SUM(J) = SUMJ * DSQRT(ONE - TEMP**2) GO TO 110 90 SUM(J) = V2NORM(M-K, QR(K1,J)) 110 CONTINUE C ..........END OF K-TH HOUSEHOLDER TRANSFORMATION.......... 120 CONTINUE C GO TO 999 C ..........ERROR EXIT ON K-TH TRANSFORMATION.......... 210 IERR = -K GO TO 230 C ..........NO NON-ZERO ACCEPTABLE PIVOT FOUND.......... 220 IERR = K 230 DO 240 I = K, N ALPHA(I) = ZERO IF (I .GT. K) CALL VSCOPY(I-K, QR(K,I), ZERO) 240 CONTINUE C ..........RETURN TO CALLER.......... 999 RETURN C ..........LAST CARD OF QRFACT.......... END DOUBLE PRECISION FUNCTION RELDST(P, D, X, X0) REL00010 C C *** COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0 *** C *** NL2SOL VERSION 2.2 *** C INTEGER P DOUBLE PRECISION D(P), X(P), X0(P) C/+ DOUBLE PRECISION DABS C/ INTEGER I DOUBLE PRECISION EMAX, T, XMAX, ZERO C/6 DATA ZERO/0.D+0/ C/7 C PARAMETER (ZERO=0.D+0) C/ C EMAX = ZERO XMAX = ZERO DO 10 I = 1, P T = DABS(D(I) * (X(I) - X0(I))) IF (EMAX .LT. T) EMAX = T T = D(I) * (DABS(X(I)) + DABS(X0(I))) IF (XMAX .LT. T) XMAX = T 10 CONTINUE RELDST = ZERO IF (XMAX .GT. ZERO) RELDST = EMAX / XMAX 999 RETURN C *** LAST CARD OF RELDST FOLLOWS *** END SUBROUTINE RPTMUL(FUNC, IPIVOT, J, NN, P, RD, X, Y, Z) RPT00010 C C *** FUNC = 1... SET Y = RMAT * (PERM**T) * X. C *** FUNC = 2... SET Y = PERM * (RMAT**T) * RMAT * (PERM**T) * X. C *** FUNC = 3... SET Y = PERM * (RMAT**T) X. C C C *** PERM = MATRIX WHOSE I-TH COL. IS THE IPIVOT(I)-TH UNIT VECTOR. C *** RMAT IS THE UPPER TRIANGULAR MATRIX WHOSE STRICT UPPER TRIANGLE C *** IS STORED IN J AND WHOSE DIAGONAL IS STORED IN RD. C *** Z IS A SCRATCH VECTOR. C *** X AND Y MAY SHARE STORAGE. C INTEGER FUNC, NN, P INTEGER IPIVOT(P) DOUBLE PRECISION J(NN,P), RD(P), X(P), Y(P), Z(P) C C *** LOCAL VARIABLES *** C INTEGER I, IM1, K, KM1 DOUBLE PRECISION ZK C C *** EXTERNAL FUNCTION *** C EXTERNAL DOTPRD DOUBLE PRECISION DOTPRD C C----------------------------------------------------------------------- C IF (FUNC .GT. 2) GO TO 50 C C *** FIRST SET Z = (PERM**T) * X *** C DO 10 I = 1, P K = IPIVOT(I) Z(I) = X(K) 10 CONTINUE C C *** NOW SET Y = RMAT * Z *** C Y(1) = Z(1) * RD(1) IF (P .LE. 1) GO TO 40 DO 30 K = 2, P KM1 = K - 1 ZK = Z(K) DO 20 I = 1, KM1 20 Y(I) = Y(I) + J(I,K)*ZK Y(K) = ZK*RD(K) 30 CONTINUE C 40 IF (FUNC .LE. 1) GO TO 999 GO TO 70 C 50 DO 60 I = 1, P 60 Y(I) = X(I) C C *** SET Z = (RMAT**T) * Y *** C 70 Z(1) = Y(1) * RD(1) IF (P .EQ. 1) GO TO 90 DO 80 I = 2, P IM1 = I - 1 Z(I) = Y(I)*RD(I) + DOTPRD(IM1, J(1,I), Y) 80 CONTINUE C C *** NOW SET Y = PERM * Z *** C 90 DO 100 I = 1, P K = IPIVOT(I) Y(K) = Z(I) 100 CONTINUE C 999 RETURN C *** LAST CARD OF RPTMUL FOLLOWS *** END SUBROUTINE SLUPDT(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE, SLU00010 1 Y) C C *** UPDATE SYMMETRIC A SO THAT A * STEP = Y *** C *** (LOWER TRIANGLE OF A STORED ROWWISE *** C C *** PARAMETER DECLARATIONS *** C INTEGER P DOUBLE PRECISION A(1), COSMIN, SIZE, STEP(P), U(P), W(P), 1 WCHMTD(P), WSCALE, Y(P) C DIMENSION A(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, J, K DOUBLE PRECISION DENMIN, SDOTWM, T, UI, WI C C *** CONSTANTS *** DOUBLE PRECISION HALF, ONE, ZERO C C *** INTRINSIC FUNCTIONS *** C/+ DOUBLE PRECISION DABS, DMIN1 C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL DOTPRD, SLVMUL, V2NORM DOUBLE PRECISION DOTPRD, V2NORM C C/6 DATA HALF/0.5D+0/, ONE/1.D+0/, ZERO/0.D+0/ C/7 C PARAMETER (HALF=0.5D+0, ONE=1.D+0, ZERO=0.D+0) C/ C C----------------------------------------------------------------------- C SDOTWM = DOTPRD(P, STEP, WCHMTD) DENMIN = COSMIN * V2NORM(P,STEP) * V2NORM(P,WCHMTD) WSCALE = ONE IF (DENMIN .NE. ZERO) WSCALE = DMIN1(ONE, DABS(SDOTWM/DENMIN)) T = ZERO IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM DO 10 I = 1, P 10 W(I) = T * WCHMTD(I) CALL SLVMUL(P, U, A, STEP) T = HALF * (SIZE * DOTPRD(P, STEP, U) - DOTPRD(P, STEP, Y)) DO 20 I = 1, P 20 U(I) = T*W(I) + Y(I) - SIZE*U(I) C C *** SET A = A + U*(W**T) + W*(U**T) *** C K = 1 DO 40 I = 1, P UI = U(I) WI = W(I) DO 30 J = 1, I A(K) = SIZE*A(K) + UI*W(J) + WI*U(J) K = K + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST CARD OF SLUPDT FOLLOWS *** END SUBROUTINE SLVMUL(P, Y, S, X) SLV00010 C C *** SET Y = S * X, S = P X P SYMMETRIC MATRIX. *** C *** LOWER TRIANGLE OF S STORED ROWWISE. *** C C *** PARAMETER DECLARATIONS *** C INTEGER P DOUBLE PRECISION S(1), X(P), Y(P) C DIMENSION S(P*(P+1)/2) C C *** LOCAL VARIABLES *** C INTEGER I, IM1, J, K DOUBLE PRECISION XI C C *** NO INTRINSIC FUNCTIONS *** C C *** EXTERNAL FUNCTION *** C EXTERNAL DOTPRD DOUBLE PRECISION DOTPRD C C----------------------------------------------------------------------- C J = 1 DO 10 I = 1, P Y(I) = DOTPRD(I, S(J), X) J = J + I 10 CONTINUE C IF (P .LE. 1) GO TO 999 J = 1 DO 40 I = 2, P XI = X(I) IM1 = I - 1 J = J + 1 DO 30 K = 1, IM1 Y(K) = Y(K) + S(J)*XI J = J + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST CARD OF SLVMUL FOLLOWS *** END LOGICAL FUNCTION STOPX(IDUMMY) STO00010 C *****PARAMETERS... INTEGER IDUMMY C C .................................................................. C C *****PURPOSE... C THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION) C FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT C THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A C DYNAMIC STOPX. C C *****ALGORITHM NOTES... C AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED C INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A C FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT C (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX. C C .................................................................. C STOPX = .FALSE. RETURN END SUBROUTINE VAXPY(P, W, A, X, Y) VAX00010 C C *** SET W = A*X + Y -- W, X, Y = P-VECTORS, A = SCALAR *** C INTEGER P DOUBLE PRECISION A, W(P), X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 W(I) = A*X(I) + Y(I) RETURN END SUBROUTINE VCOPY(P, Y, X) VCO00010 C C *** SET Y = X, WHERE X AND Y ARE P-VECTORS *** C INTEGER P DOUBLE PRECISION X(P), Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = X(I) RETURN END SUBROUTINE VSCOPY(P, Y, S) VSC00010 C C *** SET P-VECTOR Y TO SCALAR S *** C INTEGER P DOUBLE PRECISION S, Y(P) C INTEGER I C DO 10 I = 1, P 10 Y(I) = S RETURN END DOUBLE PRECISION FUNCTION V2NORM(P, X) V2N00010 C C *** RETURN THE 2-NORM OF THE P-VECTOR X, TAKING *** C *** CARE TO AVOID THE MOST LIKELY UNDERFLOWS. *** C INTEGER P DOUBLE PRECISION X(P) C INTEGER I, J DOUBLE PRECISION ONE, R, SCALE, SQTETA, T, XI, ZERO C/+ DOUBLE PRECISION DABS, DSQRT C/ EXTERNAL RMDCON DOUBLE PRECISION RMDCON C C/6 DATA ONE/1.D+0/, ZERO/0.D+0/ C/7 C PARAMETER (ONE=1.D+0, ZERO=0.D+0) C SAVE SQTETA C/ DATA SQTETA/0.D+0/ C IF (P .GT. 0) GO TO 10 V2NORM = ZERO GO TO 999 10 DO 20 I = 1, P IF (X(I) .NE. ZERO) GO TO 30 20 CONTINUE V2NORM = ZERO GO TO 999 C 30 SCALE = DABS(X(I)) IF (I .LT. P) GO TO 40 V2NORM = SCALE GO TO 999 40 T = ONE IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2) C C *** SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE C *** SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE. C *** THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS. C J = I + 1 DO 60 I = J, P XI = DABS(X(I)) IF (XI .GT. SCALE) GO TO 50 R = XI / SCALE IF (R .GT. SQTETA) T = T + R*R GO TO 60 50 R = SCALE / XI IF (R .LE. SQTETA) R = ZERO T = ONE + T * R*R SCALE = XI 60 CONTINUE C V2NORM = SCALE * DSQRT(T) 999 RETURN C *** LAST CARD OF V2NORM FOLLOWS *** END C/////////////////////////////////////////////////////////////////////// C *** RUN NL2SOL ON VARIOUS TEST PROBLEMS, PRINT SUMMARY STATISTICS. NLM00010 C C *****COMMON STORAGE WITH NLTEST. C COMMON /TESTCM/ V, RS, JAC, NOUT, NPROB, XSCAL1, XSCAL2, IS, IV COMMON /TESTCH/ NAME, IRC INTEGER IS(6,50), IV(80), JAC, NOUT, NPROB, XSCAL1, XSCAL2 REAL RS(5,50) C/6 REAL NAME(2,50) INTEGER IRC(50) C/7 C CHARACTER NAME(2,50)*4, IRC(50)*1 C/ DOUBLE PRECISION V(1736) C C C .................................................................. C C *****PURPOSE. C THIS MAIN PROGRAM CALLS NLTEST TO RUN NL2SOL, THE NONLINEAR C LEAST-SQUARES SOLVER OF REF. 1, ON VARIOUS TEST PROBLEMS. C C C *****APPLICATION AND USAGE RESTRICTIONS. C THIS MAIN DRIVER IS INTENDED TO CHECK WHETHER THE NL2SOL C (NONLINEAR LEAST-SQUARES) PACKAGE WAS SUCCESSFULLY C TRANSPORTED TO A NEW MACHINE. C C *****ALGORITHM NOTES. C THE TEST PROBLEMS USED ARE FROM REFERENCES (2), (3), AND (4). C SOME ADDITIONAL TEST PROBLEMS WERE SUGGESTED BY JORGE MORE (PRI- C VATE COMMUNICATION). CALLS PASSING THESE PROBLEMS TO NLTEST HAVE C BEEN COMMENTED OUT (SINCE THERE ARE ENOUGH OTHER PROBLEMS), BUT C NOT REMOVED, SINCE THEY MAY BE OF INTEREST TO OTHER RESEARCHERS. C C *****FUNCTIONS AND SUBROUTINES CALLED. C C DFAULT - ESTABLISHES THE DEFAULT PARAMETER SETTINGS FOR C IV AND V. C C IMDCON - IMDCON(2) RETURNS I/O UNIT NUMBER ON WHICH NLTEST C WRITES A SUMMARY OF EACH TEST RUN. C C IVVSET - SUPPLIES NONDEFAULT VALUES FOR IV AND V. C C NLTEST - CALLS NL2SOL, THE NONLINEAR LEAST-SQUARES C PROBLEM SOLVER. C C TODAY - SUPPLIES DATE AND TIME (OR CURRENT VERSION OF NL2SOL). C C *****REFERENCES. C C (1). DENNIS, J.E.. GAY, D.M.. AND WELSCH, R.E. (1980), C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, C SUBMITTED TO ACM TRANS. MATH. SOFTWARE. C UNDER REVISION. C C (2). GILL, P.E.. AND MURRAY, W. (1976),ALGORITHMS FOR THE C SOLUTION OF THE NON-LINEAR LEAST-SQUARES PROBLEM, C NPL REPORT NAC71,(NATIONAL PHYSICAL LABORATORY, C DIVISION OF NUMERICAL ANALYSIS AND COMPUTING, C TEDDINGTON,MIDDLESEX,ENGLAND). C C (3) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS C OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING, C EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER, C ACADEMIC PRESS, NEW YORK. C C (4) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON- C LIKE METHOD BASED UPON GAUSSIAN ELIMINATION, C SIAM J. NUMER. ANAL. 6, PP. 560-569. C C *****GENERAL. C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C .................................................................. C .................................................................. C C *****INTRINSIC FUNCTIONS. C/+ INTEGER MOD DOUBLE PRECISION DMAX1 C/ C *****EXTERNAL FUNCTIONS AND SUBROUTINES. EXTERNAL DFAULT, IMDCON, IVVSET, NLTEST, TODAY INTEGER IMDCON C C *****LOCAL VARIABLES. LOGICAL RSTART INTEGER I, J, K, MXFCSV, MXITSV, PU C/6 INTEGER JTYP(2) REAL DATIME(4) C/7 C CHARACTER DATIME(4)*4, JTYP(2)*1 C/ C C/6 DATA RSTART/.FALSE./, JTYP(1),JTYP(2)/1H ,1H*/ C/7 C DATA RSTART/.FALSE./, JTYP(1),JTYP(2)/' ','*'/ C/ C C----------------------------------------------------------------------- C C *** ESTABLISH DEFAULT PARAMETER SETTINGS *** CALL DFAULT (IV, V) NOUT = IMDCON(2) C C *** NON-DEFAULT PARAMETER SETTINGS *** C CALL IVVSET(IV, V) PU = IV(21) C JAC = 1 NPROB = 0 XSCAL1 = 1 XSCAL2 = 3 C C/6 CALL NLTEST(2,2,1,4HROSN,4HBROK,RSTART) CALL NLTEST(3,3,2,4HHELI,4HX ,RSTART) CALL NLTEST(4,4,3,4HSING,4HULAR,RSTART) CALL NLTEST(7,4,4,4HWOOD,4HS ,RSTART) XSCAL2 = 1 CALL NLTEST(3,3,5,4HZANG,4HWILL,RSTART) XSCAL2 = 3 CALL NLTEST(5,3,6,4HENGV,4HALL ,RSTART) CALL NLTEST(2,2,7,4HBRAN,4HIN ,RSTART) XSCAL2 = 2 CALL NLTEST(3,2,8,4HBEAL,4HE ,RSTART) CALL NLTEST(5,4,9,4HCRAG,4HG ,RSTART) XSCAL2 = 2 CALL NLTEST(10,3,10,4HBOX ,4H ,RSTART) MXFCSV = IV(17) MXITSV = IV(18) IV(17) = 20 IV(18) = 15 XSCAL2 = 1 CALL NLTEST(15,15,11,4HDAVI,4HDON1,RSTART) IV(17) = MXFCSV IV(18) = MXITSV XSCAL2 = 3 CALL NLTEST(2,2,12,4HFRDS,4HTEIN,RSTART) XSCAL2 = 1 CALL NLTEST(31,6,13,4HWATS,4HON6 ,RSTART) CALL NLTEST(31,9,14,4HWATS,4HON9 ,RSTART) CALL NLTEST(31,12,15,4HWATS,4HON12,RSTART) MXFCSV = IV(17) IV(17) = 20 MXITSV = IV(18) IV(18) = 15 CALL NLTEST(31,20,16,4HWATS,4HON20,RSTART) IV(17) = MXFCSV IV(18) = MXITSV XSCAL2 = 2 CALL NLTEST(8,8,17,4HCHEB,4HQD8 ,RSTART) XSCAL2 = 3 CALL NLTEST(20,4,18,4HBROW,4HN ,RSTART) CALL NLTEST(15,3,19,4HBARD,4H ,RSTART) XSCAL2 = 1 CALL NLTEST(10,2,20,4HJENN,4HRICH,RSTART) XSCAL2 = 3 CALL NLTEST(11,4,21,4HKOWA,4HLIK ,RSTART) XSCAL2 = 1 CALL NLTEST(33,5,22,4HOSBO,4HRNE1,RSTART) XSCAL2 = 2 CALL NLTEST(65,11,23,4HOSBO,4HRNE2,RSTART) XSCAL2 = 3 CALL NLTEST(3,2,24,4HMADS,4HEN ,RSTART) XSCAL2 = 1 IV(17) = 400 IV(18) = 300 CALL NLTEST(16,3,25,4HMEYE,4HR ,RSTART) C/7 C CALL NLTEST(2,2,1,'ROSN','BROK',RSTART) C CALL NLTEST(3,3,2,'HELI','X ',RSTART) C CALL NLTEST(4,4,3,'SING','ULAR',RSTART) C CALL NLTEST(7,4,4,'WOOD','S ',RSTART) C XSCAL2 = 1 C CALL NLTEST(3,3,5,'ZANG','WILL',RSTART) C XSCAL2 = 3 C CALL NLTEST(5,3,6,'ENGV','ALL ',RSTART) C CALL NLTEST(2,2,7,'BRAN','IN ',RSTART) C XSCAL2 = 2 C CALL NLTEST(3,2,8,'BEAL','E ',RSTART) C CALL NLTEST(5,4,9,'CRAG','G ',RSTART) C XSCAL2 = 2 C CALL NLTEST(10,3,10,'BOX ',' ',RSTART) C MXFCSV = IV(17) C MXITSV = IV(18) C IV(17) = 20 C IV(18) = 15 C XSCAL2 = 1 C CALL NLTEST(15,15,11,'DAVI','DON1',RSTART) C IV(17) = MXFCSV C IV(18) = MXITSV C XSCAL2 = 3 C CALL NLTEST(2,2,12,'FRDS','TEIN',RSTART) C XSCAL2 = 1 C CALL NLTEST(31,6,13,'WATS','ON6 ',RSTART) C CALL NLTEST(31,9,14,'WATS','ON9 ',RSTART) C CALL NLTEST(31,12,15,'WATS','ON12',RSTART) C MXFCSV = IV(17) C IV(17) = 20 C MXITSV = IV(18) C IV(18) = 15 C CALL NLTEST(31,20,16,'WATS','ON20',RSTART) C IV(17) = MXFCSV C IV(18) = MXITSV C XSCAL2 = 2 C CALL NLTEST(8,8,17,'CHEB','QD8 ',RSTART) C XSCAL2 = 3 C CALL NLTEST(20,4,18,'BROW','N ',RSTART) C CALL NLTEST(15,3,19,'BARD',' ',RSTART) C XSCAL2 = 1 C CALL NLTEST(10,2,20,'JENN','RICH',RSTART) C XSCAL2 = 3 C CALL NLTEST(11,4,21,'KOWA','LIK ',RSTART) C XSCAL2 = 1 C CALL NLTEST(33,5,22,'OSBO','RNE1',RSTART) C XSCAL2 = 2 C CALL NLTEST(65,11,23,'OSBO','RNE2',RSTART) C XSCAL2 = 3 C CALL NLTEST(3,2,24,'MADS','EN ',RSTART) C XSCAL2 = 1 C IV(17) = 400 C IV(18) = 300 C CALL NLTEST(16,3,25,'MEYE','R ',RSTART) C/ C *** BROWN5 *** C CALL NLTEST(5,5,26,4HBROW,4HN5 ,RSTART) C *** BROWN10 *** C CALL NLTEST(10,10,27,4HBROW,4HN10 ,RSTART) C *** BROWN30 *** C CALL NLTEST(30,30,28,4HBROW,4HN30 ,RSTART) C *** BROWN40 *** C CALL NLTEST(40,40,29,4HBROW,4HN40 ,RSTART) C *** BARD+10 *** C CALL NLTEST(15,3,30,4HBARD,4H+10 ,RSTART) C *** KOWALIK AND OSBORNE + 10 *** C CALL NLTEST(11,4,31,4HKOWA,4HL+10,RSTART) C *** MEYER + 10 *** C CALL NLTEST(16,3,32,4HMEYE,4HR+10,RSTART) C *** WATSON6 + 10 *** C CALL NLTEST(31,6,33,4HWAT6,4H+10 ,RSTART) C *** WATSON9 + 10 *** C CALL NLTEST(31,9,34,4HWAT9,4H+10 ,RSTART) C *** WATSON12 + 10 *** C CALL NLTEST(31,12,35,4HWAT1,4H2+10,RSTART) C *** WATSON20 + 10 *** C CALL NLTEST(31,20,36,4HWAT2,4H0+10,RSTART) C C *** REPEAT TWO TESTS USING FINITE-DIFFERENCE JACOBIAN *** C JAC = 2 XSCAL2 = 1 C IV(17) = 50 IV(18) = 40 C/6 CALL NLTEST(2,2,1,4HROSN,4HBROK,RSTART) C/7 C CALL NLTEST(2,2,1,'ROSN','BROK',RSTART) C/ V(29) = DMAX1(1.0D-7, V(29)) IV(17) = 30 IV(18) = 20 C *** BROWN *** C/6 CALL NLTEST(20,4,18,4HBROW,4HN ,RSTART) C/7 C CALL NLTEST(20,4,18,'BROW','N ',RSTART) C/ C IF (NPROB .EQ. 0 .OR. PU .EQ. 0) STOP CALL TODAY(DATIME) DO 130 K = 1, NPROB IF (MOD(K,56) .EQ. 1) WRITE(PU, 110) DATIME, NPROB 110 FORMAT(1H1,11X,2A4,2X,2A4,10X,10HSUMMARY OF,I4, 1 22H NL2SOL TEST RUNS.....,10X, 2 32H(* = FINITE-DIFFERENCE JACOBIAN)/ 3 48H0 PROBLEM N P NITER NF NG IV1 X0SCAL,5X, 4 39HFINAL F PRELDF NRELDF RELDX/) J = IS(6,K) WRITE(PU,120) JTYP(J), NAME(1,K), NAME(2,K), 1 (IS(I,K), I=1,5), IRC(K), (RS(I,K), I=1,5) 120 FORMAT(1X,A1,2A4,2I4,I7,2I5,3X,A1,F9.1,E13.3,3E11.3) 130 CONTINUE C STOP C...... LAST CARD OF NLMAIN ............................................ END SUBROUTINE IVVSET(IV, V) IVV00010 C C *** SUPPLY NONDEFAULT IV AND V VALUES FOR NLMAIN (NL2SOL VER. 2.2). C INTEGER IV(24) DOUBLE PRECISION V(100) C C ACTIVATE THE NEXT LINE TO TURN OFF DETAILED SUMMARY PRINTING C IV(21) = 0 RETURN END SUBROUTINE NLTEST (N, P, NEX, TITLE1, TITLE2, RSTART) NLT00010 C C *** CALL NL2SOL, SAVE AND PRINT STATISTICS *** C C INTEGER N, P, NEX LOGICAL RSTART C/6 REAL TITLE1, TITLE2 C/7 C CHARACTER*4 TITLE1, TITLE2 C/ C COMMON /TESTCM/ V, RS, JAC, NOUT, NPROB, XSCAL1, XSCAL2, IS, IV COMMON /TESTCH/ NAME, IRC INTEGER IS(6,50), IV(80), JAC, NOUT, NPROB, XSCAL1, XSCAL2 REAL RS(5,50) C/6 INTEGER IRC(50) REAL NAME(2,50) C/7 C CHARACTER NAME(2,50)*4, IRC(50)*1 C/ DOUBLE PRECISION V(1736) C LOGICAL RSTRT INTEGER I, IRUN, PU, UIP(1) C/6 INTEGER ALG(2), JTYP(2), RC(10) REAL DATIME(4) C/7 C CHARACTER*4 DATIME(4) C CHARACTER*2 ALG(2) C CHARACTER*1 JTYP(2), RC(10) C/ DOUBLE PRECISION ONE, T, URPARM(1), X(20), X0SCAL, ZERO C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C EXTERNAL NL2SNO, NL2SOL, TESTR, TESTJ, TODAY, XINIT C C *** IV AND V SUBSCRIPTS *** C INTEGER F, F0, NFCALL, NFCOV, NGCALL, NITER, NREDUC, PREDUC, 1 PRUNIT, RELDX C C/6 DATA F/10/, F0/13/, NFCALL/6/, NFCOV/40/, NGCALL/30/, 1 NGCOV/41/, NITER/31/, NREDUC/6/, PREDUC/7/, 2 PRUNIT/21/, RELDX/17/ C/7 C PARAMETER (F=10, F0=13, NFCALL=6, NFCOV=40, NGCALL=30, C 1 NGCOV=41, NITER=31, NREDUC=6, PREDUC=7, C 2 PRUNIT=21, RELDX=17) C/ C/6 DATA ONE/1.D+0/, ZERO/0.D+0/ C/7 C PARAMETER (ONE=1.D+0, ZERO=0.D+0) C/ C/6 DATA ALG(1),ALG(2)/2HOL,2HNO/, JTYP(1),JTYP(2)/1H ,1H*/ DATA RC(1)/1H./, RC(2)/1H+/, RC(3)/1HX/, RC(4)/1HR/, RC(5)/1HB/, 1 RC(6)/1HA/, RC(7)/1HS/, RC(8)/1HF/, RC(9)/1HE/, RC(10)/1HI/ C/7 C DATA ALG(1),ALG(2)/'OL','NO'/, JTYP(1),JTYP(2)/' ','*'/ C DATA RC(1)/'.'/, RC(2)/'+'/, RC(3)/'X'/, RC(4)/'R'/, RC(5)/'B'/, C 1 RC(6)/'A'/, RC(7)/'S'/, RC(8)/'F'/, RC(9)/'E'/, RC(10)/'I'/ C/ C C----------------------------------------------------------------------- C UIP(1) = NEX RSTRT = RSTART IF (RSTRT) GO TO 20 PU = IV(PRUNIT) CALL TODAY(DATIME) IF (PU .NE. 0) WRITE(PU,10) ALG(JAC), TITLE1, TITLE2, DATIME 10 FORMAT (1H1//11H ***** NL2S,A2,12H ON PROBLEM ,2A4,6H *****,6X, 1 2A4,2X,2A4) C 20 DO 100 IRUN = XSCAL1, XSCAL2 IF (RSTRT) GO TO 40 IV(1) = 12 X0SCAL = 1.0D1 ** (IRUN-1) C C *** INITIALIZE THE SOLUTION VECTOR X *** CALL XINIT(P, X, NEX) DO 30 I = 1, P 30 X(I) = X0SCAL * X(I) C 40 IF (JAC .EQ. 1) 1 CALL NL2SOL(N,P,X,TESTR,TESTJ,IV,V,UIP,URPARM,TESTR) IF (JAC .EQ. 2) 1 CALL NL2SNO(N,P,X,TESTR,IV,V,UIP,URPARM,TESTR) IF (.NOT. RSTRT .AND. NPROB .LT. 50) NPROB = NPROB + 1 NAME(1,NPROB) = TITLE1 NAME(2,NPROB) = TITLE2 IS(1,NPROB) = N IS(2,NPROB) = P IS(3,NPROB) = IV(NITER) IS(4,NPROB) = IV(NFCALL) - IV(NFCOV) IS(5,NPROB) = IV(NGCALL) - IV(NGCOV) I = IV(1) IRC(NPROB) = RC(I) IS(6,NPROB) = JAC RS(1,NPROB) = X0SCAL RS(2,NPROB) = V(F) T = ONE IF (V(F0) .GT. ZERO) T = V(PREDUC) / V(F0) RS(3,NPROB) = T T = ONE IF (V(F0) .GT. ZERO) T = V(NREDUC) / V(F0) RS(4,NPROB) = T RS(5,NPROB) = V(RELDX) RSTRT = .FALSE. IF (NOUT .EQ. 0) GO TO 100 IF (NPROB .EQ. 1) WRITE(NOUT,50) DATIME 50 FORMAT(1H1,11X,2A4,2X,2A4,10X,24HNL2SOL TEST SUMMARY.....,10X, 1 32H(* = FINITE-DIFFERENCE JACOBIAN)/ 2 48H0 PROBLEM N P NITER NF NG IV1 X0SCAL,5X, 3 39HFINAL F PRELDF NRELDF RELDX/) WRITE(NOUT,60) JTYP(JAC), TITLE1, TITLE2, 1 (IS(I,NPROB),I=1,5),IRC(NPROB),(RS(I,NPROB),I=1,5) 60 FORMAT(1X,A1,2A4,2I4,I7,2I5,3X,A1,F9.1,E13.3,3E11.3) 100 CONTINUE C 999 RETURN C *** LAST CARD OF NLTEST FOLLOWS *** END SUBROUTINE TESTJ(N, P, X, NFCALL, J, UIPARM, URPARM, UFPARM) TSJ00010 C C *** PARAMETERS *** C INTEGER N, P, NFCALL, UIPARM(1) DOUBLE PRECISION X(P), J(N,P), URPARM(1) EXTERNAL UFPARM C C .................................................................. C .................................................................. C C *****PURPOSE. C THIS ROUTINE EVALUATES THE JACOBIAN MATRIX J FOR THE VARIOUS C TEST PROBLEMS LISTED IN REFERENCES (1), (2), AND (3). C C *****PARAMETER DESCRIPTION. C ON INPUT. C C NN IS THE ROW DIMENSION OF J AS DECLARED IN THE CALLING C PROGRAM. C N IS THE ACTUAL NUMBER OF ROWS IN J AND IS THE LENGTH OF R. C P IS THE NUMBER OF PARAMETERS BEING ESTIMATED AND HENCE IS C THE LENGTH OF X. C X IS THE VECTOR OF PARAMETERS AT WHICH THE JACOBIAN MATRIX J C IS TO BE COMPUTED. C NFCALL IS THE INVOCATION COUNT OF TESTR AT THE TIME WHEN R C WAS EVALUATED AT X. TESTR IGNORES NFCALL. C R IS THE RESIDUAL VECTOR AT X (AND IS IGNORED). C NEX = UIPARM(1) IS THE INDEX OF THE PROBLEM CURRENTLY BEING C SOLVED. C URPARM IS A USER PARAMETER VECTOR (AND IS IGNORED). C UFPARM IS A USER ENTRY POINT PARAMETER (AND IS IGNORED). C TESTR IS THE SUBROUTINE THAT COMPUTES R (AND IS IGNORED). C C ON OUTPUT. C C J IS THE JACOBIAN MATRIX AT X. C C *****APPLICATION AND USAGE RESTRICTIONS. C THESE TEST PROBLEMS MAY BE USED TO TEST LEAST-SQUARES SOLVERS C SUCH AS NL2SOL. IN PARTICULAR, THESE PROBLEMS MAY BE USED TO C CHECK WHETHER NL2SOL HAS BEEN SUCCESSFULLY TRANSPORTED TO C A PARTICULAR MACHINE. C C *****ALGORITHM NOTES. C NONE C C *****SUBROUTINES AND FUNCTIONS CALLED. C NONE C C *****REFERENCES C (1) GILL, P.E.; & MURRAY, W. (1976), ALGORITHMS FOR THE SOLUTION C OF THE NON-LINEAR LEAST-SQUARES PROBLEM, NPL REPORT NAC71. C C (2) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS C OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING, C EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER, C ACADEMIC PRESS, NEW YORK. C C (3) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON- C LIKE METHOD BASED UPON GAUSSIAN ELIMINATION, C SIAM J. NUMER. ANAL. 6, PP. 560-569. C C *****GENERAL. C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C .................................................................. C .................................................................. C C *** LOCAL VARIABLES AND CONSTANTS *** C DOUBLE PRECISION E, EXPMIN, R2, T, THETA, TI, TIM1, TIP1, TPI, 1 TPIM1, TPIP1, TWOPI, U, UFTOLG, UKOW(11), V, W, Z, ZERO INTEGER I, K, NEX, NM1 C *** INTRINSIC FUNCTIONS *** C/+ REAL FLOAT DOUBLE PRECISION DBLE, DCOS, DEXP, DLOG, DMIN1, DSIN, DSQRT C/ EXTERNAL RMDCON DOUBLE PRECISION DFLOAT, RMDCON C C/6 C/6 T DATA TWOPI/6.283185307179586D+0/, ZERO/0.D+0/ C/7 C PARAMETER (TWOPI=6.283185307179586D+0, ZERO=0.D+0) C/ C/6 C/7 C SAVE EXPMIN, UFTOLG C/ DATA UKOW(1)/4.0D0/, UKOW(2)/2.0D0/, UKOW(3)/1.0D0/, 1 UKOW(4)/5.0D-1/, UKOW(5)/2.5D-1/, UKOW(6)/1.67D-1/, 2 UKOW(7)/1.25D-1/, UKOW(8)/1.0D-1/, UKOW(9)/8.33D-2/, 3 UKOW(10)/7.14D-2/, UKOW(11)/6.25D-2/ C *** MACHINE DEPENDENT CONSTANT *** DATA EXPMIN/0.0D0/, UFTOLG/0.D0/ C DFLOAT(II) = DBLE(FLOAT(II)) C C----------------------------------------------------------------------- C NEX = UIPARM(1) GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100, 1 1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100, 2 2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100, 3 2500, 1300, 1400, 1500, 1600), NEX C C *** ROSENBROCK *** 100 J(1,1) = -2.0D1*X(1) J(1,2) = 1.0D1 J(2,1) = -1.0D0 J(2,2) = 0.0D0 GO TO 9999 C *** HELIX *** 200 T = X(1)**2 + X(2)**2 TI = 1.D2/(TWOPI*T) J(1,1) = TI*X(2) T = 1.D1/DSQRT(T) J(2,1) = X(1)*T J(3,1) = 0.D0 J(1,2) = -TI*X(1) J(2,2) = X(2)*T J(3,2) = 0.D0 J(1,3) = 1.D1 J(2,3) = 0.D0 J(3,3) = 1.D0 GO TO 9999 C *** SINGULAR *** 300 DO 301 K = 1,4 DO 301 I = 1,4 301 J(I,K) = 0.D0 J(1,1) = 1.D0 J(1,2) = 1.D1 J(2,3) = DSQRT(5.D0) J(2,4) = -J(2,3) J(3,2) = 2.D0*(X(2) - 2.D0*X(3)) J(3,3) = -2.D0*J(3,2) J(4,1) = DSQRT(4.D1)*(X(1) - X(4)) J(4,4) = -J(4,1) GO TO 9999 C *** WOODS *** 400 DO 401 K = 1,4 DO 401 I = 1,7 401 J(I,K) = 0.D0 J(1,1) = -2.D1*X(1) J(1,2) = 1.D1 J(2,1) = -1.D0 J(3,4) = DSQRT(9.D1) J(3,3) = -2.D0*X(3)*J(3,4) J(4,3) = -1.D0 J(5,2) = DSQRT(9.9D0) J(5,4) = J(5,2) J(6,2) = DSQRT(0.2D0) J(7,4) = J(6,2) GO TO 9999 C *** ZANGWILL *** 500 DO 501 K = 1,3 DO 501 I = 1,3 501 J(I,K) = 1.D0 J(1,2) = -1.D0 J(2,1) = -1.D0 J(3,3) = -1.D0 GO TO 9999 C *** ENGVALL *** 600 J(1,1) = 2.D0*X(1) J(1,2) = 2.D0*X(2) J(1,3) = 2.D0*X(3) J(2,1) = J(1,1) J(2,2) = J(1,2) J(2,3) = 2.D0*(X(3) - 2.D0) J(3,1) = 1.D0 J(3,2) = 1.D0 J(3,3) = 1.D0 J(4,1) = 1.D0 J(4,2) = 1.D0 J(4,3) = -1.D0 T = 2.D0*(5.D0*X(3) - X(1) + 1.D0) J(5,1) = 3.D0*X(1)**2 - T J(5,2) = 6.D0*X(2) J(5,3) = 5.D0*T GO TO 9999 C *** BRANIN *** 700 J(1,1) = 4.D0 J(1,2) = 4.D0 J(2,1) = 3.D0 + (X(1) - 2.D0)*(3.D0*X(1) - 2.D0*X(2) - 2.D0) + 1 X(2)*X(2) J(2,2) = 1.D0 + 2.D0*(2.D0*X(1) - X(2)*X(2)) - (X(1) - X(2))**2 GO TO 9999 C *** BEALE *** 800 J(1,1) = X(2) - 1.D0 J(1,2) = X(1) J(2,1) = X(2)**2 - 1.D0 J(2,2) = 2.D0*X(1)*X(2) J(3,1) = X(2)**3 - 1.D0 J(3,2) = 3.D0*X(1)*(X(2)**2) GO TO 9999 C *** CRAGG & LEVY *** 900 DO 901 I = 1,5 DO 901 K = 1,4 901 J(I,K) = 0.D0 T = DEXP(X(1)) J(1,2) = -2.D0*(T - X(2)) J(1,1) = -T * J(1,2) J(2,2) = 3.0D1*(X(2) - X(3))**2 J(2,3) = -J(2,2) J(3,3) = 2.D0*DSIN(X(3) - X(4))/(DCOS(X(3) - X(4)))**3 J(3,4) = -J(3,3) J(4,1) = 4.D0*X(1)**3 J(5,4) = 1.D0 GO TO 9999 C *** BOX *** 1000 IF (EXPMIN .EQ. ZERO) EXPMIN = 1.999D0*DLOG(RMDCON(2)) DO 1001 I = 1,10 TI = -0.1D0*DFLOAT(I) E = ZERO T = X(1)*TI IF (T .GE. EXPMIN) E = DEXP(T) J(I,1) = TI*E E = ZERO T = X(2)*TI IF (T .GE. EXPMIN) E = DEXP(T) J(I,2) = -TI*E J(I,3) = DEXP(1.D1*TI) - DEXP(TI) 1001 CONTINUE GO TO 9999 C *** DAVIDON 1 *** 1100 NM1 = N-1 DO 1101 I = 1,NM1 TI = DFLOAT(I) T = 1.D0 DO 1101 K = 1,P J(I,K) = T T = T*TI 1101 CONTINUE J(N,1) = 1.D0 DO 1102 K = 2,P 1102 J(N,K) = 0.D0 GO TO 9999 C *** FREUDENSTEIN & ROTH *** 1200 J(1,1) = 1.D0 J(1,2) = -2.D0 + X(2)*(1.D1 - 3.D0*X(2)) J(2,1) = 1.D0 J(2,2) = -1.4D1 + X(2)*(2.D0 + 3.D0*X(2)) GO TO 9999 C *** WATSON *** 1300 CONTINUE 1400 CONTINUE 1500 CONTINUE 1600 DO 1603 I = 1,29 TI = DFLOAT(I)/2.9D1 R2 = X(1) T= 1.D0 DO 1601 K = 2,P T = T*TI R2 = R2 + T*X(K) 1601 CONTINUE R2 = -2.D0*R2 J(I,1) = R2 T = 1.D0 R2 = TI*R2 DO 1602 K = 2,P J(I,K) = T*(DFLOAT(K-1) + R2) T = T*TI 1602 CONTINUE 1603 CONTINUE DO 1604 I = 30,31 DO 1604 K = 2,P 1604 J(I,K) = 0.D0 J(30,1) = 1.D0 J(31,1) = -2.D0*X(1) J(31,2) = 1.D0 GO TO 9999 C *** CHEBYQUAD *** 1700 DO 1701 K = 1,N TIM1 = -1.D0/DFLOAT(N) Z = 2.D0*X(K) - 1.D0 TI = Z*TIM1 TPIM1 = 0.D0 TPI = 2.D0*TIM1 Z = Z + Z DO 1701 I = 1,N J(I,K) = TPI TPIP1 = 4.D0*TI + Z*TPI - TPIM1 TPIM1 = TPI TPI = TPIP1 TIP1 = Z*TI - TIM1 TIM1 = TI TI = TIP1 1701 CONTINUE GO TO 9999 C *** BROWN AND DENNIS *** 1800 DO 1801 I = 1, N TI = 0.2D0*DFLOAT(I) J(I,1) = 2.0D0*(X(1) + X(2)*TI - DEXP(TI)) J(I,2) = TI*J(I,1) T = DSIN(TI) J(I,3) = 2.0D0*(X(3) + X(4)*T - DCOS(TI)) J(I,4) = T*J(I,3) 1801 CONTINUE GO TO 9999 C *** BARD *** 1900 DO 1901 I = 1,15 J(I,1) = -1.D0 U = DFLOAT(I) V = 1.6D1 - U W = DMIN1 (U,V) T = U/(X(2)*V + X(3)*W)**2 J(I,2) = V*T J(I,3) = W*T 1901 CONTINUE GO TO 9999 C *** JENNRICH & SAMPSON *** 2000 DO 2001 I = 1,10 TI = DFLOAT(I) J(I,1) = -TI*DEXP(TI*X(1)) J(I,2) = -TI*DEXP(TI*X(2)) 2001 CONTINUE GO TO 9999 C *** KOWALIK & OSBORNE *** 2100 DO 2101 I = 1,11 T = -1.D0/(UKOW(I)**2 + X(3)*UKOW(I) + X(4)) J(I,1) = T*(UKOW(I)**2 + X(2)*UKOW(I)) J(I,2) = X(1)*UKOW(I)*T T = T*J(I,1)*X(1) J(I,3) = UKOW(I)*T J(I,4) = T 2101 CONTINUE GO TO 9999 C *** OSBORNE 1 *** 2200 DO 2201 I = 1,33 TI = 1.0D1*DFLOAT(1-I) J(I,1) = -1.D0 J(I,2) = -DEXP(X(4)*TI) J(I,3) = -DEXP(X(5)*TI) J(I,4) = TI*X(2)*J(I,2) J(I,5) = TI*X(3)*J(I,3) 2201 CONTINUE GO TO 9999 C *** OSBORNE 2 *** C *** UFTOLG IS A MACHINE-DEPENDENT CONSTANT. IT IS JUST SLIGHTLY C *** LARGER THAN THE LOG OF THE SMALLEST POSITIVE MACHINE NUMBER. 2300 IF (UFTOLG .EQ. 0.D0) UFTOLG = 1.999D0 * DLOG(RMDCON(2)) DO 2302 I = 1,65 TI = DFLOAT(1 - I)*1.D-1 J(I,1) = -DEXP(X(5)*TI) J(I,5) = X(1)*TI*J(I,1) DO 2301 K = 2,4 T = X(K + 7) + TI R2 = 0.D0 THETA = -X(K+4)*T*T IF (THETA .GT. UFTOLG) R2 = -DEXP(THETA) J(I,K) = R2 R2 = -T*R2*X(K) J(I,K+4) = R2*T J(I,K+7) = 2.D0*X(K+4)*R2 2301 CONTINUE 2302 CONTINUE GO TO 9999 C *** MADSEN *** 2400 J(1,1) = 2.D0*X(1) + X(2) J(1,2) = 2.D0*X(2) + X(1) J(2,1) = DCOS(X(1)) J(2,2) = 0.D0 J(3,1) = 0.D0 J(3,2) = -DSIN(X(2)) GO TO 9999 C *** MEYER *** 2500 DO 2501 I = 1, 16 TI = DFLOAT(5*I + 45) U = TI + X(3) T = DEXP(X(2)/U) J(I,1) = T J(I,2) = X(1)*T/U J(I,3) = -X(1)*X(2)*T/(U*U) 2501 CONTINUE GO TO 9999 C *** BROWN *** 2600 CONTINUE 2700 CONTINUE 2800 CONTINUE 2900 NM1 = N - 1 DO 2901 K = 1, N DO 2901 I = 1, NM1 J(I,K) = 1.0D0 IF (I .EQ. K) J(I,K) = 2.0D0 2901 CONTINUE DO 2903 K = 1, N T = 1.0D0 DO 2902 I = 1,N IF (I .NE. K) T = T*X(I) 2902 CONTINUE J(N,K) = T 2903 CONTINUE GO TO 9999 C C 9999 RETURN END SUBROUTINE TESTR(N, P, X, NFCALL, R, UIPARM, URPARM, UFPARM) TES00010 C C *****PARAMETERS. C INTEGER N, P, NFCALL, UIPARM(1) DOUBLE PRECISION X(P), R(N), URPARM(1) EXTERNAL UFPARM C C .................................................................. C .................................................................. C C *****PURPOSE. C THIS ROUTINE EVALUATES R FOR THE VARIOUS TEST FUNCTIONS IN C REFERENCES (1), (2), AND (3), AS WELL AS FOR SOME VARIATIONS C SUGGESTED BY JORGE MORE (PRIVATE COMMUNICATION) ON SOME OF C THESE TEST PROBLEMS (FOR NEX .GE. 30). C C *****PARAMETER DESCRIPTION. C ON INPUT. C C N IS THE LENGTH OF R. C P IS THE LENGTH OF X. C X IS THE POINT AT WHICH THE RESIDUAL VECTOR R IS TO BE C COMPUTED. C NFCALL IS THE INVOCATION COUNT OF TESTR. C NEX = UIPARM(1) IS THE INDEX OF THE PROBLEM CURRENTLY BEING C SOLVED. C URPARM IS A USER PARAMETER VECTOR (AND IS IGNORED). C UFPARM IS A USER ENTRY POINT PARAMETER (AND IS IGNORED). C C ON OUTPUT. C C R IS THE RESIDUAL VECTOR AT X. C C *****APPLICATION AND USAGE RESTRICTIONS. C THESE TEST PROBLEMS MAY BE USED TO TEST LEAST-SQUARES SOLVERS C SUCH AS NL2SOL. IN PARTICULAR, THESE PROBLEMS MAY BE USED TO C CHECK WHETHER NL2SOL HAS BEEN SUCCESSFULLY TRANSPORTED TO C A PARTICULAR MACHINE. C C *****ALGORITHM NOTES. C NONE C C *****SUBROUTINES AND FUNCTIONS CALLED. C NONE C C *****REFERENCES C (1) GILL, P.E.. & MURRAY, W. (1976), ALGORITHMS FOR THE SOLUTION C OF THE NON-LINEAR LEAST-SQUARES PROBLEM, NPL REPORT NAC71. C C (2) MEYER, R.R. (1970), THEORETICAL AND COMPUTATIONAL ASPECTS C OF NONLINEAR REGRESSION, PP. 465-486 OF NONLINEAR PROGRAMMING, C EDITED BY J.B. ROSEN, O.L.MANGASARIAN, AND K. RITTER, C ACADEMIC PRESS, NEW YORK. C C (3) BROWN, K.M. (1969), A QUADRATICALLY CONVERGENT NEWTON- C LIKE METHOD BASED UPON GAUSSIAN ELIMINATION, C SIAM J. NUMER. ANAL. 6, PP. 560-569. C C *****GENERAL. C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C .................................................................. C .................................................................. C C *** LOCAL VARIABLES AND CONSTANTS *** C DOUBLE PRECISION E1, E2, FLOATN, RI, R1, R2, T, THETA, TI, TIM1, 1 TIP1, TWOPI, T1, T2, U, V, W, Z DOUBLE PRECISION YBARD(15), YKOW(11), UKOW(11), YOSB1(33), 1 YOSB2(65), YMEYER(16) INTEGER I, J, NEX, NM1 DOUBLE PRECISION EXPMAX, EXPMIN, UFTOLG C *** INTRINSIC FUNCTIONS *** C/+ INTEGER MOD REAL FLOAT DOUBLE PRECISION DATAN2, DBLE, DCOS, DEXP, DLOG, DMIN1, DSIN, 1 DSQRT C/ EXTERNAL RMDCON DOUBLE PRECISION DFLOAT, RMDCON C/6 DATA TWOPI/6.283185307179586D+0/ C/7 C PARAMETER (TWOPI=6.283185307179586D+0) C/ C/6 C/7 C SAVE EXPMAX, EXPMIN, UFTOLG C/ DATA YBARD(1)/1.4D-1/, YBARD(2)/1.8D-1/, YBARD(3)/2.2D-1/, 1 YBARD(4)/2.5D-1/, YBARD(5)/2.9D-1/, YBARD(6)/3.2D-1/, 2 YBARD(7)/3.5D-1/, YBARD(8)/3.9D-1/, YBARD(9)/3.7D-1/, 3 YBARD(10)/5.8D-1/, YBARD(11)/7.3D-1/, YBARD(12)/9.6D-1/, 4 YBARD(13)/1.34D0/, YBARD(14)/2.10D0/, YBARD(15)/4.39D0/ DATA YKOW(1)/1.957D-1/, YKOW(2)/1.947D-1/, YKOW(3)/1.735D-1/, 1 YKOW(4)/1.600D-1/, YKOW(5)/8.44D-2/, YKOW(6)/6.27D-2/, 2 YKOW(7)/4.56D-2/, YKOW(8)/3.42D-2/, YKOW(9)/3.23D-2/, 3 YKOW(10)/2.35D-2/, YKOW(11)/2.46D-2/ DATA UKOW(1)/4.0D0/, UKOW(2)/2.0D0/, UKOW(3)/1.0D0/, 1 UKOW(4)/5.0D-1/, UKOW(5)/2.5D-1/, UKOW(6)/1.67D-1/, 2 UKOW(7)/1.25D-1/, UKOW(8)/1.0D-1/, UKOW(9)/8.33D-2/, 3 UKOW(10)/7.14D-2/, UKOW(11)/6.25D-2/ DATA YOSB1(1)/8.44D-1/, YOSB1(2)/9.08D-1/, YOSB1(3)/9.32D-1/, 1 YOSB1(4)/9.36D-1/, YOSB1(5)/9.25D-1/, YOSB1(6)/9.08D-1/, 2 YOSB1(7)/8.81D-1/, YOSB1(8)/8.50D-1/, YOSB1(9)/8.18D-1/, 3 YOSB1(10)/7.84D-1/, YOSB1(11)/7.51D-1/, YOSB1(12)/7.18D-1/, 4 YOSB1(13)/6.85D-1/, YOSB1(14)/6.58D-1/, YOSB1(15)/6.28D-1/, 5 YOSB1(16)/6.03D-1/, YOSB1(17)/5.80D-1/, YOSB1(18)/5.58D-1/, 6 YOSB1(19)/5.38D-1/, YOSB1(20)/5.22D-1/, YOSB1(21)/5.06D-1/, 7 YOSB1(22)/4.90D-1/, YOSB1(23)/4.78D-1/, YOSB1(24)/4.67D-1/, 8 YOSB1(25)/4.57D-1/, YOSB1(26)/4.48D-1/, YOSB1(27)/4.38D-1/, 9 YOSB1(28)/4.31D-1/, YOSB1(29)/4.24D-1/, YOSB1(30)/4.20D-1/, A YOSB1(31)/4.14D-1/, YOSB1(32)/4.11D-1/, YOSB1(33)/4.06D-1/ DATA YOSB2(1)/1.366D0/, YOSB2(2)/1.191D0/, YOSB2(3)/1.112D0/, 1 YOSB2(4)/1.013D0/, YOSB2(5)/9.91D-1/, YOSB2(6)/8.85D-1/, 2 YOSB2(7)/8.31D-1/, YOSB2(8)/8.47D-1/, YOSB2(9)/7.86D-1/, 3 YOSB2(10)/7.25D-1/, YOSB2(11)/7.46D-1/, YOSB2(12)/6.79D-1/, 4 YOSB2(13)/6.08D-1/, YOSB2(14)/6.55D-1/, YOSB2(15)/6.16D-1/, 5 YOSB2(16)/6.06D-1/, YOSB2(17)/6.02D-1/, YOSB2(18)/6.26D-1/, 6 YOSB2(19)/6.51D-1/, YOSB2(20)/7.24D-1/, YOSB2(21)/6.49D-1/, 7 YOSB2(22)/6.49D-1/, YOSB2(23)/6.94D-1/, YOSB2(24)/6.44D-1/, 8 YOSB2(25)/6.24D-1/, YOSB2(26)/6.61D-1/, YOSB2(27)/6.12D-1/, 9 YOSB2(28)/5.58D-1/, YOSB2(29)/5.33D-1/, YOSB2(30)/4.95D-1/, A YOSB2(31)/5.00D-1/, YOSB2(32)/4.23D-1/, YOSB2(33)/3.95D-1/, B YOSB2(34)/3.75D-1/, YOSB2(35)/3.72D-1/, YOSB2(36)/3.91D-1/, C YOSB2(37)/3.96D-1/, YOSB2(38)/4.05D-1/, YOSB2(39)/4.28D-1/, D YOSB2(40)/4.29D-1/, YOSB2(41)/5.23D-1/, YOSB2(42)/5.62D-1/, E YOSB2(43)/6.07D-1/, YOSB2(44)/6.53D-1/, YOSB2(45)/6.72D-1/, F YOSB2(46)/7.08D-1/, YOSB2(47)/6.33D-1/, YOSB2(48)/6.68D-1/, G YOSB2(49)/6.45D-1/, YOSB2(50)/6.32D-1/, YOSB2(51)/5.91D-1/, H YOSB2(52)/5.59D-1/, YOSB2(53)/5.97D-1/, YOSB2(54)/6.25D-1/, I YOSB2(55)/7.39D-1/, YOSB2(56)/7.10D-1/, YOSB2(57)/7.29D-1/, J YOSB2(58)/7.20D-1/, YOSB2(59)/6.36D-1/, YOSB2(60)/5.81D-1/ DATA YOSB2(61)/4.28D-1/, YOSB2(62)/2.92D-1/, YOSB2(63)/1.62D-1/, 1 YOSB2(64)/9.8D-2/, YOSB2(65)/5.4D-2/ DATA YMEYER(1)/3.478D4/, YMEYER(2)/2.861D4/, YMEYER(3)/2.365D4/, 1 YMEYER(4)/1.963D4/, YMEYER(5)/1.637D4/, YMEYER(6)/1.372D4/, 2 YMEYER(7)/1.154D4/, YMEYER(8)/9.744D3/, YMEYER(9)/8.261D3/, 3 YMEYER(10)/7.030D3/, YMEYER(11)/6.005D3/, YMEYER(12)/5.147D3/, 4 YMEYER(13)/4.427D3/, YMEYER(14)/3.820D3/, YMEYER(15)/3.307D3/, 5 YMEYER(16)/2.872D3/ C DATA EXPMAX/0.D0/, UFTOLG/0.D0/ C DFLOAT(II) = DBLE(FLOAT(II)) C C----------------------------------------------------------------------- C NEX = UIPARM(1) GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100, 1 1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100, 2 2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100, 3 2500, 1300, 1400, 1500, 1600), NEX C C *** ROSENBROCK *** 100 R(1) = 1.0D1*(X(2) - X(1)**2) R(2) = 1.0D0 - X(1) GO TO 9999 C *** HELIX *** 200 THETA = DATAN2(X(2), X(1))/TWOPI IF (X(1) .LE. 0.D0 .AND. X(2) .LE. 0.D0) THETA = THETA + 1.D0 R(1) = 1.0D1*(X(3) - 1.0D1*THETA) R(2) = 1.0D1*(DSQRT(X(1)**2 + X(2)**2) - 1.0D0) R(3) = X(3) GO TO 9999 C *** SINGULAR *** 300 R(1) = X(1) + 1.0D1*X(2) R(2) = DSQRT(5.0D0)*(X(3) - X(4)) R(3) = (X(2) - 2.0D0*X(3))**2 R(4) = DSQRT(1.0D1)*(X(1) - X(4))**2 GO TO 9999 C *** WOODS *** 400 R(1) = 1.0D1*(X(2) - X(1)**2) R(2) = 1.0D0 - X(1) R(3) = DSQRT(9.0D1)*(X(4) - X(3)**2) R(4) = 1.0D0 - X(3) R(5) = DSQRT(9.9D0)*(X(2) + X(4) - 2.D0) T = DSQRT(2.0D-1) R(6) = T*(X(2) - 1.0D0) R(7) = T*(X(4) - 1.0D0) GO TO 9999 C *** ZANGWILL 500 R(1) = X(1) - X(2) + X(3) R(2) = -X(1) + X(2) + X(3) R(3) = X(1) + X(2) - X(3) GO TO 9999 C *** ENGVALL *** 600 R(1) = X(1)**2 + X(2)**2 + X(3)**2 - 1.0D0 R(2) = X(1)**2 + X(2)**2 + (X(3) - 2.0D0)**2 - 1.0D0 R(3) = X(1) + X(2) + X(3) - 1.0D0 R(4) = X(1) + X(2) - X(3) + 1.0D0 R(5) = X(1)**3 + 3.0D0*X(2)**2 + (5.0D0*X(3) - X(1) + 1.0D0)**2 1 - 3.6D1 GO TO 9999 C *** BRANIN *** 700 R(1) = 4.0D0*(X(1) + X(2)) R(2) = R(1) + (X(1) - X(2))*((X(1) - 2.0D0)**2 + 1 X(2)**2 - 1.0D0) GO TO 9999 C *** BEALE *** 800 R(1) = 1.5D0 - X(1)*(1.0D0 - X(2)) R(2) = 2.25D0 - X(1)*(1.0D0 - X(2)**2) R(3) = 2.625D0 - X(1)*(1.0D0 - X(2)**3) GO TO 9999 C *** CRAGG AND LEVY *** 900 R(1) = (DEXP(X(1)) - X(2))**2 R(2) = 1.0D1*(X(2) - X(3))**3 R(3) = ( DSIN(X(3) - X(4)) / DCOS(X(3) - X(4)) )**2 R(4) = X(1)**4 R(5) = X(4) - 1.0D0 GO TO 9999 C *** BOX *** 1000 IF (EXPMAX .GT. 0.D0) GO TO 1001 EXPMAX = 1.999D0 * DLOG(RMDCON(5)) EXPMIN = 1.999D0 * DLOG(RMDCON(2)) 1001 IF (-EXPMAX .GE. DMIN1(X(1), X(2), X(3))) GO TO 1003 DO 1002 I = 1,10 TI = -0.1D0*DFLOAT(I) T1 = TI*X(1) E1 = 0.D0 IF (T1 .GT. EXPMIN) E1 = DEXP(T1) T2 = TI*X(2) E2 = 0.D0 IF (T2 .GT. EXPMIN) E2 = DEXP(T2) R(I) = (E1 - E2) - X(3)*(DEXP(TI) - DEXP(1.0D1*TI)) 1002 CONTINUE GO TO 9999 1003 NFCALL = -1 GO TO 9999 C *** DAVIDON 1 *** 1100 NM1 = N - 1 DO 1102 I = 1, NM1 R1 = 0.0D0 TI = DFLOAT(I) T = 1.D0 DO 1101 J = 1,P R1 = R1 + T*X(J) T = T*TI 1101 CONTINUE R(I) = R1 1102 CONTINUE R(N) = X(1) - 1.0D0 GO TO 9999 C *** FREUDENSTEIN AND ROTH *** 1200 R(1) = -1.3D1 + X(1) - 2.0D0*X(2) + 5.0D0*X(2)**2 - X(2)**3 R(2) = -2.9D1 + X(1) - 1.4D1*X(2) + X(2)**2 + X(2)**3 GO TO 9999 C *** WATSON *** 1300 CONTINUE 1400 CONTINUE 1500 CONTINUE 1600 DO 1602 I = 1, 29 TI = DFLOAT(I)/2.9D1 R1 = 0.0D0 R2 = X(1) T = 1.0D0 DO 1601 J = 2, P R1 = R1 + DFLOAT(J-1)*T*X(J) T = T*TI R2 = R2 + T*X(J) 1601 CONTINUE R(I) = R1 - R2*R2 - 1.0D0 IF (NEX .GE. 33 .AND. NEX .LE. 36) R(I) = R(I) + 10.D0 1602 CONTINUE R(30) = X(1) R(31) = X(2) - X(1)**2 - 1.0D0 IF (NEX .LT. 33 .OR. NEX .GT. 36) GO TO 9999 R(30) = R(30) + 10.D0 R(31) = R(31) + 10.D0 GO TO 9999 C *** CHEBYQUAD *** 1700 DO 1701 I = 1,N 1701 R(I) = 0.0D0 DO 1702 J = 1,N TIM1 = 1.0D0 TI = 2.0D0*X(J) - 1.0D0 Z = TI + TI DO 1702 I = 1,N R(I) = R(I) + TI TIP1 = Z*TI -TIM1 TIM1 = TI TI = TIP1 1702 CONTINUE FLOATN = DFLOAT(N) DO 1703 I = 1,N TI = 0.0D0 IF (MOD(I,2) .EQ. 0) TI = -1.0D0/DFLOAT(I*I - 1) R(I) = TI - R(I)/FLOATN 1703 CONTINUE GO TO 9999 C *** BROWN AND DENNIS *** 1800 DO 1801 I = 1, N TI = 0.2D0*DFLOAT(I) R(I) = (X(1) + X(2)*TI - DEXP(TI))**2 + 1 (X(3) + X(4)*DSIN(TI) - DCOS(TI))**2 1801 CONTINUE GO TO 9999 C *** BARD *** 1900 DO 1901 I = 1, 15 U = DFLOAT(I) V = 1.6D1 - U W = DMIN1(U,V) R(I) = YBARD(I) - (X(1) + U/(X(2)*V + X(3)*W)) IF (NEX .EQ. 30) R(I) = R(I) + 10.D0 1901 CONTINUE GO TO 9999 C *** JENNRICH AND SAMPSON *** 2000 DO 2001 I = 1, 10 TI = DFLOAT(I) R(I) = 2.0D0 + 2.0D0*TI - (DEXP(TI*X(1)) + 1 DEXP(TI*X(2))) 2001 CONTINUE GO TO 9999 C *** KOWALIK AND OSBORNE *** 2100 DO 2101 I = 1, 11 R(I) = YKOW(I) - X(1)*(UKOW(I)**2 + X(2)*UKOW(I))/(UKOW(I)**2 + 1 X(3)*UKOW(I) + X(4)) IF (NEX .EQ. 31) R(I) = R(I) + 10.D0 2101 CONTINUE GO TO 9999 C *** OSBORNE 1 *** 2200 DO 2201 I = 1, 33 TI = 1.0D1*DFLOAT(1-I) R(I) = YOSB1(I) - (X(1) + X(2)*DEXP(X(4)*TI) + 1 X(3)*DEXP(X(5)*TI)) 2201 CONTINUE GO TO 9999 C *** OSBORNE 2 *** C *** UFTOLG IS A MACHINE-DEPENDENT CONSTANT. IT IS JUST SLIGHTLY C *** LARGER THAN THE LOG OF THE SMALLEST POSITIVE MACHINE NUMBER. 2300 IF (UFTOLG .EQ. 0.D0) UFTOLG = 1.999D0 * DLOG(RMDCON(2)) DO 2302 I = 1, 65 TI = 0.1D0*DFLOAT(1-I) RI = X(1)*DEXP(X(5)*TI) DO 2301 J = 2, 4 T = 0.D0 THETA = -X(J+4) * (TI + X(J+7))**2 IF (THETA .GT. UFTOLG) T = DEXP(THETA) RI = RI + X(J)*T 2301 CONTINUE R(I) = YOSB2(I) - RI 2302 CONTINUE GO TO 9999 C *** MADSEN *** 2400 R(1) = X(1)**2 + X(2)**2 + X(1)*X(2) R(2) = DSIN(X(1)) R(3) = DCOS(X(2)) GO TO 9999 C *** MEYER *** 2500 DO 2501 I = 1, 16 TI = DFLOAT(5*I + 45) R(I)=X(1)*DEXP(X(2)/(TI + X(3))) - YMEYER(I) IF (NEX .EQ. 32) R(I) = R(I) + 10.D0 2501 CONTINUE GO TO 9999 C *** BROWN *** 2600 CONTINUE 2700 CONTINUE 2800 CONTINUE 2900 T = X(1) - DFLOAT(N + 1) DO 2901 I = 2, N 2901 T = T + X(I) NM1 = N - 1 DO 2902 I = 1, NM1 2902 R(I) = T + X(I) T = X(1) DO 2903 I = 2, N 2903 T = T * X(I) R(N) = T - 1.0D0 GO TO 9999 C 9999 RETURN C ..... LAST CARD OF TESTR ......................................... END SUBROUTINE TODAY(DATIME) TOD00010 C C *** SUPPLY SUMSOL VERSION *** C C/6 REAL DATIME(4), DT1, DT2, DT3, DT4 DATA DT1,DT2,DT3,DT4/4HNL2S,4HOL ,4HVER.,4H2.2 / C/7 C CHARACTER*4 DATIME(4), DT1, DT2, DT3, DT4 C DATA DT1,DT2,DT3,DT4/'NL2S','OL ','VER.','2.2 '/ C/ C DATIME(1) = DT1 DATIME(2) = DT2 DATIME(3) = DT3 DATIME(4) = DT4 999 RETURN C *** LAST LINE OF DATIME FOLLOWS *** END SUBROUTINE XINIT(P, X, NEX) XIN00010 C C *****PARAMETERS... C INTEGER NEX, P DOUBLE PRECISION X(P) C C .................................................................. C C *****PURPOSE... C THIS ROUTINE INITIALIZES THE SOLUTION VECTOR X ACCORDING TO C THE INITIAL VALUES FOR THE VARIOUS TEST FUNCTIONS GIVEN IN C REFERENCES (1), (2), AND (3). C SUBROUTINES TESTR AND TESTJ. (SEE TESTR FOR REFERENCES.) C C *****PARAMETER DESCRIPTION... C ON INPUT... C C NEX IS THE TEST PROBLEM NUMBER. C C P IS THE NUMBER OF PARAMETERS. C C ON OUTPUT... C C X IS THE INITIAL GUESS TO THE SOLUTION. C C *****APPLICATION AND USAGE RESTRICTIONS... C THIS ROUTINE IS CALLED BY NLTEST. C C .................................................................. C C *****LOCAL VARIABLES... INTEGER I DOUBLE PRECISION PP1INV C *****INTRINSIC FUNCTIONS... C/+ REAL FLOAT DOUBLE PRECISION DBLE C/ DFLOAT(II) = DBLE(FLOAT(II)) C GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, 1100, 1 1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100, 2 2200, 2300, 2400, 2500, 2600, 2700, 2800, 2900, 1900, 2100, 3 2500, 1300, 1400, 1500, 1600),NEX C C *** ROSENBROCK *** 100 X(1) = -1.2D0 X(2) = 1.0D0 GO TO 9999 C *** HELIX *** 200 X(1) = -1.0D0 X(2) = 0.0D0 X(3) = 0.0D0 GO TO 9999 C *** SINGULAR *** 300 X(1) = 3.0D0 X(2) = -1.0D0 X(3) = 0.0D0 X(4) = 1.0D0 GO TO 9999 C *** WOODS *** 400 X(1) = -3.0D0 X(2) = -1.0D0 X(3) = -3.0D0 X(4) = -1.0D0 GO TO 9999 C *** ZANGWILL *** 500 X(1) = 1.0D2 X(2) = -1.0D0 X(3) = 2.5D0 GO TO 9999 C *** ENGVALL *** 600 X(1) = 1.0D0 X(2) = 2.0D0 X(3) = 0.0D0 GO TO 9999 C *** BRANIN *** 700 X(1) = 2.0D0 X(2) = 0.0D0 GO TO 9999 C *** BEALE *** 800 X(1) = 1.0D-1 X(2) = 1.0D-1 GO TO 9999 C *** CRAGG AND LEVY *** 900 X(1) = 1.0D0 X(2) = 2.0D0 X(3) = 2.0D0 X(4) = 2.0D0 GO TO 9999 C *** BOX *** 1000 X(1) = 0.0D0 X(2) = 1.0D1 X(3) = 2.0D1 GO TO 9999 C *** DAVIDON 1 *** 1100 DO 1101 I = 1,P 1101 X(I) = 0.0D0 GO TO 9999 C *** FREUDENSTEIN AND ROTH *** 1200 X(1) = 1.5D1 X(2) = -2.0D0 GO TO 9999 C *** WATSON *** 1300 CONTINUE 1400 CONTINUE 1500 CONTINUE 1600 DO 1601 I = 1,P 1601 X(I) = 0.0D0 GO TO 9999 C *** CHEBYQUAD *** 1700 PP1INV = 1.0D0/DFLOAT(P + 1) DO 1701 I = 1, P 1701 X(I) = DFLOAT(I)*PP1INV GO TO 9999 C *** BROWN AND DENNIS *** 1800 X(1) = 2.5D1 X(2) = 5.0D0 X(3) = -5.0D0 X(4) = -1.0D0 GO TO 9999 C *** BARD *** 1900 X(1) = 1.D0 X(2) = 1.D0 X(3) = 1.D0 GO TO 9999 C *** JENNRICH AND SAMPSON *** 2000 X(1) = 3.0D-1 X(2) = 4.0D-1 GO TO 9999 C *** KOWALIK AND OSBORNE *** 2100 X(1) = 2.5D-1 X(2) = 3.9D-1 X(3) = 4.15D-1 X(4) = 3.9D-1 GO TO 9999 C *** OSBORNE 1 *** 2200 X(1) = 5.0D-1 X(2) = 1.5D0 X(3) = -1.0D0 X(4) = 1.0D-2 X(5) = 2.0D-2 GO TO 9999 C *** OSBORNE 2 *** 2300 X(1) = 1.3D0 X(2) = 6.5D-1 X(3) = 6.5D-1 X(4) = 7.0D-1 X(5) = 6.0D-1 X(6) = 3.0D0 X(7) = 5.0D0 X(8) = 7.0D0 X(9) = 2.0D0 X(10) = 4.5D0 X(11) = 5.5D0 GO TO 9999 C *** MADSEN *** 2400 X(1) = 3.0D0 X(2) = 1.0D0 GO TO 9999 C *** MEYER ** 2500 X(1) = 2.0D-2 X(2) = 4.0D3 X(3) = 2.5D2 GO TO 9999 C *** BROWN *** 2600 CONTINUE 2700 CONTINUE 2800 CONTINUE 2900 DO 2901 I = 1, P 2901 X(I) = 5.D-1 GO TO 9999 C C 9999 RETURN END